calc-to-asm.rkt

#lang plait

(define-type TinyAsm
  ; load heap[addr] into register[reg]
  [loadA (reg : Number) (addr : Number)]

  ; store register[reg] into heap[addr]
  [storeA (reg : Number) (addr : Number)]

  ; set register[reg] = value
  [setregA (reg : Number) (value : Number)]

  ; trap: gives a runtime error if register[0] != v
  [trapA (v : Number)]

  ; set register[0] = register[1] + register[2]
  [addA]

  ; set register[0] = register[1] * register[2]
  [mulA])


; 3 registers initialized to -1
(define (mt-reg) (make-vector 3 -1))

; 100 heap locations initialized to -1
(define (mt-heap) (make-vector 100 -1))

; run a list of instructions and return the contents of reg[0]
(define (asm-interp (insn : (Listof TinyAsm)) (regvec : (Vectorof Number)) (heap : (Vectorof Number)))
  (type-case (Listof TinyAsm) insn
             [(cons insn tl)
              (begin
                (type-case TinyAsm insn
                           [(loadA reg addr) (vector-set! regvec reg (vector-ref heap addr))]
                           [(storeA reg addr) (vector-set! heap addr (vector-ref regvec reg))]
                           [(setregA reg v) (vector-set! regvec reg v)]
                           [(trapA v) (if (not (equal? (vector-ref regvec 0) v))
                                          (begin
                                            (error 'trap "Trapped"))
                                           (void))]
                           [(addA) (vector-set! regvec 0 (+ (vector-ref regvec 1) (vector-ref regvec 2)))]
                           [(mulA) (vector-set! regvec 0 (* (vector-ref regvec 1) (vector-ref regvec 2)))])
                (asm-interp tl regvec heap))]
             [else (vector-ref regvec 0)]
             ))

(test (asm-interp (list (setregA 1 1)
                        (setregA 2 4)
                        (addA)) (mt-reg) (mt-heap)) 5)
(test (asm-interp (list (setregA 1 2)
                        (storeA 1 3)
                        (loadA 2 3)
                        (addA)) (mt-reg) (mt-heap)) 4)


(define-type Calc
  [numE (n : Number)]
  [boolE (b : Boolean)]
  [addE (l : Calc) (r : Calc)]
  [andE (l : Calc) (r : Calc)]
  )

(define (fresh! b)
  (begin
    (set-box! b (+ 1 (unbox b)))
    (unbox b)))

; compiles calculator lang to TinyAsm
; returns a pair (Listof TinyAsm, Number) where the second component is
; the address that holds the result
(define (unsafe-calc-to-asm-h c fresh)
  (type-case Calc c
             [(numE n)
              ; store n in a fresh location
              (let [(addr (fresh! fresh))]
                (pair (list (setregA 0 n) (storeA 0 addr)) addr))]
             [(boolE b)
              ; encode b as 1 or 0 in a fresh location
              (let [(addr (fresh! fresh))]
                (pair (list (setregA 0 (if b 1 0)) (storeA 0 addr)) addr))]
             [(addE e1 e2)
              (letrec [(c-e1 (unsafe-calc-to-asm-h e1 fresh))
                       (c-e2 (unsafe-calc-to-asm-h e2 fresh))
                       (res (fresh! fresh))
                       (new-prog (list (loadA 1 (snd c-e1))
                                       (loadA 2 (snd c-e2))
                                       (addA)
                                       (storeA 0 res)
                                       ))]
                (pair (append (append (fst c-e1) (fst c-e2)) new-prog) res))]
             [(andE e1 e2)
              (letrec [(c-e1 (unsafe-calc-to-asm-h e1 fresh))
                       (c-e2 (unsafe-calc-to-asm-h e2 fresh))
                       (res (fresh! fresh))
                       (new-prog (list (loadA 1 (snd c-e1))
                                       (loadA 2 (snd c-e2))
                                       (mulA)
                                       (storeA 0 res)
                                       ))]
                (pair (append (append (fst c-e1) (fst c-e2)) new-prog) res))]))

(define (unsafe-calc-to-asm c)
  (let [(compiled (unsafe-calc-to-asm-h c (box 0)))]
    (append (fst compiled) (list (loadA 0 (snd compiled))))))


(test (asm-interp (unsafe-calc-to-asm (addE (numE 10) (numE 20))) (mt-reg) (mt-heap)) 30)
(test (asm-interp (unsafe-calc-to-asm (addE (addE (numE 5) (numE 10)) (numE 20))) (mt-reg) (mt-heap)) 35)
(test (asm-interp (unsafe-calc-to-asm (andE (boolE #f) (boolE #t))) (mt-reg) (mt-heap)) 0)
(test (asm-interp (unsafe-calc-to-asm (andE (boolE #t) (numE 100))) (mt-reg) (mt-heap)) 100)

; what makes the above interpreter unsafe?
; the fact that we can conjoin bools with numbers
; let's make a version of the compiler that checks at runtime whether or not we are doing something unsafe
; and raises an error if we are

; these tags will tell us the type of what we've stored in memory
(define bool-tag 1238)
(define num-tag 9283)

(define (safe-calc-to-asm-h c fresh)
  (type-case Calc c
             [(numE n)
              ; store n and tag in fresh locations: we always know that the tag's location is 1 greater than
              ; the value's location
              (let [(addr-v (fresh! fresh))
                    (addr-tag (fresh! fresh))]
                (pair (list (setregA 0 n)
                            (setregA 1 num-tag)
                            (storeA 0 addr-v)
                            (storeA 1 addr-tag)
                            ) addr-v))]
             [(boolE b)
              ; encode b as 1 or 0 in a fresh location
              (let [(addr-v (fresh! fresh))
                    (addr-tag (fresh! fresh))]
                (pair (list (setregA 0 (if b 1 0))
                            (setregA 1 bool-tag)
                            (storeA 0 addr-v)
                            (storeA 1 addr-tag)
                            ) addr-v))]
             [(addE e1 e2)
              (letrec [(c-e1 (safe-calc-to-asm-h e1 fresh))
                       (c-e2 (safe-calc-to-asm-h e2 fresh))
                       (res (fresh! fresh))
                       (addr-tag (fresh! fresh))
                       (new-prog (list
                                  ; add a check to ensure that e1 and e2 both have the correct tags
                                  (loadA 0 (+ 1 (snd c-e1)))
                                  (trapA num-tag)
                                  (loadA 0 (+ 1 (snd c-e2)))
                                  (trapA num-tag)
                                  (loadA 1 (snd c-e1))
                                  (loadA 2 (snd c-e2))
                                  (addA)
                                  (storeA 0 res)
                                  ; store the tag
                                  (setregA 1 num-tag)
                                  (storeA 1 addr-tag)
                                  ))]
                (pair (append (append (fst c-e1) (fst c-e2)) new-prog) res))]
             [(andE e1 e2)
              (letrec [(c-e1 (safe-calc-to-asm-h e1 fresh))
                       (c-e2 (safe-calc-to-asm-h e2 fresh))
                       (res (fresh! fresh))
                       (addr-tag (fresh! fresh))
                       (new-prog (list
                                  ; add a check to ensure that e1 and e2 both have the correct tags
                                  (loadA 0 (+ 1 (snd c-e1)))
                                  (trapA bool-tag)
                                  (loadA 0 (+ 1 (snd c-e2)))
                                  (trapA bool-tag)
                                  (loadA 1 (snd c-e1))
                                  (loadA 2 (snd c-e2))
                                  (mulA)
                                  (storeA 0 res)
                                  ; store the tag
                                  (setregA 1 bool-tag)
                                  (storeA 1 addr-tag)
                                  ))]
                (pair (append (append (fst c-e1) (fst c-e2)) new-prog) res))]))

(define (safe-calc-to-asm c)
  (let [(compiled (safe-calc-to-asm-h c (box 0)))]
    (append (fst compiled) (list (loadA 0 (snd compiled))))))

(test (asm-interp (safe-calc-to-asm (addE (numE 10) (numE 20))) (mt-reg) (mt-heap)) 30)
(test (asm-interp (safe-calc-to-asm (addE (addE (numE 5) (numE 10)) (numE 20))) (mt-reg) (mt-heap)) 35)
(test (asm-interp (safe-calc-to-asm (andE (andE (boolE #t) (boolE #f)) (boolE #t))) (mt-reg) (mt-heap)) 0)
(test (asm-interp (safe-calc-to-asm (andE (boolE #f) (boolE #t))) (mt-reg) (mt-heap)) 0)
(test/exn (asm-interp (safe-calc-to-asm (andE (boolE #t) (numE 100))) (mt-reg) (mt-heap)) "Trapped")