;; Interpreter with explicit continuations
;; and explicit allocation for values and
;; continuations.

;; (We've dropped letcc/continue to make things
;; simpler. Also, the environment implementation
;; now takes just one symbol and its value.)

;; To implement garbage collection, we need to
;; keep the current continuation, value, and
;; environment in registers. So `eval-expression'
;; and `apply-cont' no long take normal arguments;
;; instead, the arugments are set!ed into global
;; registers.

;; We keep using `define-datatype' for the program
;; syntax, since it could be statically allocated.
;; But we no longer use `define-datatype' for
;; procedures or continuations. Instead, they
;; are allocated manually, and a tag is put at the
;; beginning of the memory to identify the
;; record type.

;; Numbers have to be allocated, just like procedures,
;; because each number needs a tag to say that it
;; is a number.

;; Consequently, every value is represented by a memory
;; address --- which is a number! To access record
;; fields, we explicitly look up field values
;; by dereferencing an address with an offset.

;; A expval is a number
;; (which is the address of either a number or proc)

;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;

(define the-lexical-spec
  '((whitespace (whitespace) 
                skip)
    (id (letter (arbno (or letter digit "?")))
        make-symbol)
    (number ((or "" "-" "+") digit (arbno digit))
            make-number)))

(define the-grammar
  '((program (expression) a-program)

    (expression ("proc" "(" id ")"
                 expression)
                proc-exp)
    (expression (number) lit-exp)
    (expression (id) var-exp)
    (expression
      (primitive "(" expression "," expression ")")
      primapp-exp)
    (expression ("let" id "=" expression
                 "in"
                 expression)
                let-exp)
    (expression ("(" expression expression ")")
                app-exp)
    (expression ("if" expression
                 "then" expression
                 "else" expression)
                if-exp)    

    (primitive ("+")     add-prim)
    (primitive ("-")     subtract-prim)
    (primitive ("*")     mult-prim)))

(sllgen:make-define-datatypes the-lexical-spec
                              the-grammar)

;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;

;; The interpreter has the same shape as before,
;; but the arguments to `eval-expression' and
;; `apply-cont' have been converted to registers:

(define EXP #f)
(define ENV #f)
(define CONT #f)
(define VAL #f)

; eval-program : program -> expval
(define eval-program 
  (lambda (pgm)
    (init-memory!)
    (cases program pgm
      (a-program (body)
	(set! EXP body)        ;; but body into EXP register
	(set! ENV (empty-env)) ;; etc.
	(set! CONT (done-cont))
        (eval-expression)))))

;; eval-expression : -> expval
;;  Set the EXP, ENV, and CONT registers
;;  before calling.
(define (eval-expression)
    (cases expression EXP
      (lit-exp (datum) 
	       ;; Before calling `apply-cont',
	       ;; we set the CONT and VAL
	       ;; registers. But the
	       ;; CONT value is unchanged.
	       ;; `number!' takes a number
	       ;; and allocates a tagged number
	       ;; record, setting VAL.
	       (number! datum) ;; sets VAL
	       (apply-cont))
      (var-exp (id) 
	       ;; CONT is the same.
	       (apply-env! ENV id) ;; sets VAL
	       (apply-cont))
      (primapp-exp (prim rand1 rand2)
		   (set! EXP rand1)
		   ;; ENV is the same.
		   ;; `prim-other-cont!' allocates a
		   ;; continuation record, and
		   ;; installs it into the CONT
		   ;; register.
		   (prim-other-cont! prim rand2) ;; sets CONT
		   (eval-expression))
      (proc-exp (id body-exp)
		;; CONT is the same.
		;; `closure!' allocates a
		;; closure record.
		(closure! id body-exp) ;; sets VAL
		(apply-cont))
      (app-exp (rator rand)
	       (set! EXP rator)
	       ;; ENV is the same.
	       (app-arg-cont! rand) ;; sets CONT
	       (eval-expression))
      (if-exp (test then else)
	      (set! EXP test)
	      ;; ENV is the same.
	      (if-cont! then else) ;; sets CONT
	      (eval-expression))
      (let-exp (id rhs-exp body-exp)
	       (set! EXP rhs-exp)
	       ;; ENV is the same.
	       (let-cont! id body-exp) ;; sets CONT
	       (eval-expression))))

;; apply-cont : -> expval
;;  Set the VAL and CONT registers
;;  before calling.
(define (apply-cont)
  ;; The `cases' has been replaced by `cond'
  ;; with explicit tests (i.e., the style we
  ;; used at the beginning of the semester):
  (cond
   [(done-cont? CONT) VAL]
   [(prim-other-cont? CONT)
    (set! EXP (prim-other-cont->arg2 CONT))
    (set! ENV (prim-other-cont->env CONT))
    ;; As usual, `prim-cont!' allocates
    ;; a continuation and puts it in CONT.
    (prim-cont! (prim-other-cont->prim CONT)) ;; sets CONT
    (eval-expression)]
   [(prim-cont? cont)
    ;; `apply-primitive!' takes the prim and
    ;; the operands and puts the result into VAL:
    (apply-primitive! (prim-cont->prim CONT)
		      (prim-cont->arg1 CONT)
		      VAL)                   ;; sets VAL
    (set! CONT (prim-cont->cont CONT))
    (apply-cont)]
   [(app-arg-cont? CONT)
    (set! EXP (app-arg-cont->rand CONT))
    (set! ENV (app-arg-cont->env CONT))
    (app-cont!) ;; sets CONT
    (eval-expression)]
   [(app-cont? CONT)
    (let ([rator (app-cont->rator CONT)])
      (set! EXP (closure->body rator))
      (set! ENV (closure->env rator))
      (extend-env! (closure->id rator)) ;; uses ENV and VAL
      (set! CONT (app-cont->cont CONT)))
    (eval-expression)]
   [(let-cont? CONT)
    (set! EXP (let-cont->body CONT))
    (set! ENV (let-cont->env CONT))
    (extend-env! (let-cont->id CONT)) ;; uses ENV and VAL
    (set! CONT (let-cont->cont CONT))
    (eval-expression)]
   [(if-cont? CONT)
    (if (zero? (number->val VAL))
	(set! EXP (if-cont->else CONT))
	(set! EXP (if-cont->then CONT)))
    (set! ENV (if-cont->env CONT))
    (set! CONT (if-cont->cont CONT))
    (eval-expression)]))

; apply-primitive! : primitive expval expval ->
(define apply-primitive!
  (lambda (prim arg1 arg2)
    (cases primitive prim
      (add-prim  () (number! (+ (number->val arg1) 
				(number->val arg2))))
      (subtract-prim () (number! (- (number->val arg1) 
				    (number->val arg2))))
      (mult-prim  () (number! (* (number->val arg1) 
				 (number->val arg2)))))))

;;;;;;;;;;;;;;;; memory ;;;;;;;;;;;;;;;;

;; Define a tag for each kind of allocated record:

(define number-tag 1)

(define empty-env-tag 2)
(define extended-env-tag 3)

(define done-cont-tag 4)
(define app-arg-cont-tag 5)
(define app-cont-tag 6)
(define prim-other-cont-tag 7)
(define prim-cont-tag 8)
(define let-cont-tag 9)
(define if-cont-tag 10)

(define closure-tag 11)

(define moved-tag 12)

;; get-size-for-tag : num -> num
;;  Returns the size of the record
;;  for the given tag. Every record has to
;;  be at least of size 2, so it can accomodate
;;  a forwarding pointer during GC.
(define (get-size-for-tag tag)
  (cond
   [(= tag number-tag) 2]
   [(= tag empty-env-tag) 2]
   [(= tag extended-env-tag) 4]
   [(= tag done-cont-tag) 2]
   [(= tag app-arg-cont-tag) 4]
   [(= tag app-cont-tag) 3]
   [(= tag prim-other-cont-tag) 5]
   [(= tag prim-cont-tag) 4]
   [(= tag let-cont-tag) 5]
   [(= tag if-cont-tag) 5]
   [(= tag closure-tag) 4]
   [(= tag moved-tag) 0])) ;; special

;; Here is the main memory, divided into 
;; a to-space and a from-space:
(define memory-size 200)
(define to-space (make-vector memory-size))
(define from-space (make-vector memory-size))

;; Current state of allocation:
(define to-allocated 0)

;; Used during GC: pointers in all records
;; from 0 to `to-checked' have been
;; updated:
(define to-checked 0)

;; init-memory! : ->
;;  Resets main memory to have nothing allocated.
(define (init-memory!)
  (set! to-allocated 0))

;; malloc num -> num
;;  Takes the size of a record to allocate, and
;;  returns the address of the allocated record.
(define (malloc size)
  (if (< (+ to-allocated size) memory-size)
      (let ([result to-allocated])
	(set! to-allocated (+ to-allocated size))
	result)
      (begin
	(collect-garbage!)
	(malloc size))))

;; mem-set! : num num val -> 
;;  Sets the content of memory at v+n to a
(define (mem-set! v n a)
  (vector-set! to-space (+ v n) a))

;; mem-ref : num num -> val
;;  Returns the content of memory at v+n
(define (mem-ref v n)
  (vector-ref to-space (+ v n)))

;; collect-garbage! : ->
;;  Frees memory by copying all the live records,
;;  forgetting the non-live ones.
(define (collect-garbage!)
  (eopl:printf "Collecting garbage at ~a...~n" to-allocated)
  ;; Swap to and from spaces:
  (let ([tmp from-space])
    (set! from-space to-space)
    (set! to-space tmp))
  ;; Nothing yet allocated or updated in the new to space:
  (set! to-allocated 0)
  (set! to-checked 0)
  ;; Records reachable from the registers are live:
  (set! VAL (move VAL))
  (set! CONT (move CONT))
  (set! ENV (move ENV))
  ;; Copy as live all records reachable from live records:
  (loop-to-finish-gc!)
  (eopl:printf "Down to ~a~n" to-allocated))

;; move : num -> num
;;  Takes an address in from-space, and returns the
;;  corresponding record's address in to-space, copying
;;  the record if it hasn't been moved yet.
(define (move from-v)
  (let ([size (get-size-for-tag (vector-ref from-space from-v))])
    (if (= size 0)
	;; Already moved:
	(vector-ref from-space (+ from-v 1))
	;; Move it:
	(let ([to-v (malloc size)])
	  (let loop ([n 0])
	    (if (< n size)
		(begin
		  (vector-set! to-space (+ to-v n) 
			       (vector-ref from-space (+ from-v n)))
		  (loop (+ n 1)))))
	  (vector-set! from-space from-v moved-tag)
	  (vector-set! from-space (+ from-v 1) to-v)
	  to-v))))

;; loop-to-finish-gc! : ->
;;  Copy as live all records reachable from live records, and
;;  keep looping until there are no more live records to move.
;;  There can be records to move as long as `to-checked' is
;;  less than `to-allocated'.
(define (loop-to-finish-gc!)
  (if (< to-checked to-allocated)
      ;; Check pointers in the record at `to-checked'?
      (let ([check-pos to-checked]
	    [tag (mem-ref to-checked 0)])
	;; Increment the `to-checked' counter, since
	;; we're going to check this record.
	(set! to-checked (+ to-checked (get-size-for-tag tag)))
	(let ([update 
	       ;; update : num ->
	       ;;  Updates the field at the given offset
	       ;;  within the record, converting the old
	       ;;  address in from-space to the new
	       ;;  address in to-space (moving the record
	       ;;  and counting it as live, if it wasn't already.)
	       (lambda (pos)
		 (mem-set! check-pos pos 
			   (move (mem-ref check-pos pos))))])
          (cond
	   [(= tag number-tag)
	    'done]      ;; no pointers inside
	   [(= tag empty-env-tag)
	    'done]      ;; no pointers inside
	   [(= tag extended-env-tag)
	    (update 2)  ;; value
	    (update 3)] ;; old-env
	   [(= tag done-cont-tag)
	    'done]      ;; no pointers inside
	   [(= tag app-arg-cont-tag)
	    (update 2)  ;; env
	    (update 3)] ;; cont
	   [(= tag app-cont-tag)
	    (update 1)  ;; rator
	    (update 2)] ;; cont
	   [(= tag prim-other-cont-tag)
	    (update 3)  ;; env
	    (update 4)] ;; cont
	   [(= tag prim-cont-tag)
	    (update 2)  ;; arg1
	    (update 3)] ;; cont
	   [(= tag let-cont-tag)
	    (update 3)  ;; env
	    (update 4)] ;; cont
	   [(= tag if-cont-tag)
	    (update 3)  ;; env
	    (update 4)] ;; cont
	   [(= tag closure-tag)
	    (update 3)] ;; env
	   [else
	    (eopl:error 'loop-to-finish-gc! "bug, bad tag: ~a" tag)])
	  ;; loop:
	  (loop-to-finish-gc!)))))
	  
;;;;;;;;;;;;;;;; environments ;;;;;;;;;;;;;;;;

;; Abstract envrionment datatype implementation.
;; Environment extensions are now explicitly allocated.

;; An env is a number
;; (an address in memory)

;; empty-env : -> env
(define (empty-env)
  ;; Allocate a record of size 2, and fill in the
  ;; tag. We don't need the new slot, but the minimum
  ;; size of a record is 2.
  (let ([v (malloc 2)])
    (mem-set! v 0 empty-env-tag)
    v))

;; empty-env? : num -> bool
;;  Checks whether a number for a record address
;;  is the address of an empty env record, by looking
;;  at the tag:
(define (empty-env? v) (= (mem-ref v 0) empty-env-tag))

;; extend-env! : sym ->
;; The bound value and extended environment
;; are pulled from the VAL and ENV registers.
;;  The result goes in the ENV register.
(define (extend-env! sym)
  ;; Allocate a record of size 4, and fill it in.
  (let ([v (malloc 4)])
    (mem-set! v 0 extended-env-tag)
    (mem-set! v 1 sym)
    (mem-set! v 2 VAL)
    (mem-set! v 3 ENV)
    (set! ENV v)))

;; Functions that make memory dereferences into
;; extended env records easier to read:
(define (extended-env->sym v) (mem-ref v 1))
(define (extended-env->val v) (mem-ref v 2))
(define (extended-env->env v) (mem-ref v 3))

;; apply-env! : env sym ->
(define apply-env!
  (lambda (env sym)
    (cond
     [(empty-env? env)
      (eopl:error 'apply-env! "No binding for ~s" sym)]
     [else
      (if (eq? sym (extended-env->sym env))
	  (set! VAL (extended-env->val env))
	  (apply-env! (extended-env->env env) sym))])))

;;;;;;;;;;;;;;;; numbers and procs ;;;;;;;;;;;;;;;;;;;

;; number! : num -> num
;;  Allocates a number record, given the
;;  number, and returns the record's address.
;;  The result goes in the VAL register.
(define (number! n)
  ;; Allocate a record of size 2, and fill it in.
  (let ([v (malloc 2)])
    (mem-set! v 0 number-tag)
    (mem-set! v 1 n)
    (set! VAL v)))

(define (number->val v) (mem-ref v 1))

;; closure! : sym expr -> num
;;  Allocates a clsoure record, given the variable name
;;  and body expression, and returns the record's address.
;;  Pulls the environment from the ENV register.
;;  The result goes in the VAL register.
(define (closure! id body)
  (let ([v (malloc 4)])
    (mem-set! v 0 closure-tag)
    (mem-set! v 1 id)
    (mem-set! v 2 body)
    (mem-set! v 3 ENV)
    (set! VAL v)))

;; closure? : num -> bool
;;  Checks whether a number for a record address
;;  is the address of a closure record, by looking
;;  at the tag:
(define (closure? v) (= (mem-ref v 0) closure-tag))

(define (closure->id v) (mem-ref v 1))
(define (closure->body v) (mem-ref v 2))
(define (closure->env v) (mem-ref v 3))

;;;;;;;;;;;;;;;;;; Continuation records ;;;;;;;;;;;;;;;;;;;;;;

;; For each kind of continuation record, we define 
;; an allocator function, a predicate, and selector
;; functions that make the memory dereferences easier
;; to read:

(define (done-cont)
  (let ([v (malloc 2)]) ;; 2 is minimum size
    (mem-set! v 0 done-cont-tag)
    v))
(define (done-cont? v) (= (mem-ref v 0) done-cont-tag))

(define (app-arg-cont! rand) 
  (let ([v (malloc 4)])
    (mem-set! v 0 app-arg-cont-tag)
    (mem-set! v 1 rand)
    (mem-set! v 2 ENV)
    (mem-set! v 3 CONT)
    (set! CONT v)))
(define (app-arg-cont? v) (= (mem-ref v 0) app-arg-cont-tag))
(define (app-arg-cont->rand v) (mem-ref v 1))
(define (app-arg-cont->env v) (mem-ref v 2))
(define (app-arg-cont->cont v) (mem-ref v 3))

(define (app-cont!)
  (let ([v (malloc 3)])
    (mem-set! v 0 app-cont-tag)
    (mem-set! v 1 VAL)
    (mem-set! v 2 (app-arg-cont->cont CONT))
    (set! CONT v)))
(define (app-cont? v) (= (mem-ref v 0) app-cont-tag))
(define (app-cont->rator v) (mem-ref v 1))
(define (app-cont->cont v) (mem-ref v 2))

(define (prim-other-cont! prim arg2)
  (let ([v (malloc 5)])
    (mem-set! v 0 prim-other-cont-tag)
    (mem-set! v 1 prim)
    (mem-set! v 2 arg2)
    (mem-set! v 3 ENV)
    (mem-set! v 4 CONT)
    (set! CONT v)))
(define (prim-other-cont? v) (= (mem-ref v 0) prim-other-cont-tag))
(define (prim-other-cont->prim v) (mem-ref v 1))
(define (prim-other-cont->arg2 v) (mem-ref v 2))
(define (prim-other-cont->env v) (mem-ref v 3))
(define (prim-other-cont->cont v) (mem-ref v 4))

(define (prim-cont! prim)
  (let ([v (malloc 4)])
    (mem-set! v 0 prim-cont-tag)
    (mem-set! v 1 prim)
    (mem-set! v 2 VAL)
    (mem-set! v 3 (prim-other-cont->cont CONT))
    (set! CONT v)))
(define (prim-cont? v) (= (mem-ref v 0) prim-cont-tag))
(define (prim-cont->prim v) (mem-ref v 1))
(define (prim-cont->arg1 v) (mem-ref v 2))
(define (prim-cont->cont v) (mem-ref v 3))

(define (let-cont! id body)
  (let ([v (malloc 5)])
    (mem-set! v 0 let-cont-tag)
    (mem-set! v 1 id)
    (mem-set! v 2 body)
    (mem-set! v 3 ENV)
    (mem-set! v 4 CONT)
    (set! CONT v)))
(define (let-cont? v) (= (mem-ref v 0) let-cont-tag))
(define (let-cont->id v) (mem-ref v 1))
(define (let-cont->body v) (mem-ref v 2))
(define (let-cont->env v) (mem-ref v 3))
(define (let-cont->cont v) (mem-ref v 4))

(define (if-cont! then else)
  (let ([v (malloc 5)])
    (mem-set! v 0 if-cont-tag)
    (mem-set! v 1 then)
    (mem-set! v 2 else)
    (mem-set! v 3 ENV)
    (mem-set! v 4 CONT)
    (set! CONT v)))
(define (if-cont? v) (= (mem-ref v 0) if-cont-tag))
(define (if-cont->then v) (mem-ref v 1))
(define (if-cont->else v) (mem-ref v 2))
(define (if-cont->env v) (mem-ref v 3))
(define (if-cont->cont v) (mem-ref v 4))

;;;;;;;;;;;;;;;; top level ;;;;;;;;;;;;;;;;

; read-eval-print : -> [loops forever]
(define read-eval-print
  (lambda ()
    ((sllgen:make-rep-loop "-->"
			   eval-program
                           (sllgen:make-stream-parser
                            the-lexical-spec
                            the-grammar)))))

(define scan&parse
  (sllgen:make-string-parser the-lexical-spec
                             the-grammar))

(define (run string)
  (let ([p (eval-program (scan&parse string))])
    (if (closure? p)
        'closure
        (number->val p))))

;;;;;;;;;;;;;;;;; sample program ;;;;;;;;;;;;;;;;;;;;;;;

(define sum-program
  "let sum = proc(sum)
              proc(n)
                if n
                   then +(n, ((sum sum) -(n, 1)))
                   else 0
    in ((sum sum) 3)")