;;; 6.001
;;; Controller code for explicit-control evaluator with NON-STRICT
;;; parallel evaluation.
;;; Based on the regular explicit-control evaluator from Abelson and Sussman.
;;; Nikhil, November 24, 1988

;;; ****************************************************************
;;; ****************************************************************
;;; Processors have nine registers:
;;;   EXP, ENV, VAL, FUN, UNEV, ARGL, CONTINUE,
;;;   PROGRAM-COUNTER, STACK
;;; ****************************************************************
;;; New instructions:

;;;    (spawn <stack-contents>)
;;; Spawns a new processor with stack initialized with given value.

;;;    (get-I-cell <register> <I-cell>)
;;; If <I-cell> is ``empty'', place this processor on the waiting list of the
;;; I-cell, so that this instruction will be retried later; if ``full'', simply
;;; fetch the value into the given register.

;;;    (set-I-cell!  <I-cell> <value>)
;;; Store the value into the I-cell, and awaken any processors in the waiting list
;;; of the I-cell.

;;; ****************************************************************
;;; ****************************************************************
;;; Here is the controller code.

(define non-strict-controller-code '(

;;; ****************************************************************
;;; Top-level start routine
;;; Continuation label and other args on stack.
  (restore continue)
  (goto (fetch continue))

;;; ****************************************************************
;;; Top-level evaluation of an expression
;;; Assume: stack: (exp env)
;;; Effect: stop after storing eval(exp,env) in VAL register, and recording
;;; the result.

TOP-LEVEL-EVAL
  (restore exp)
  (restore env)
  (assign continue RECORD-RESULT)
  (goto EVAL-DISPATCH)

RECORD-RESULT
  (perform (record-value (fetch val)))
  (goto STOP)

;;; ****************************************************************
;;; The regular EVAL function.
;;; Assume: EXP:e, ENV:E, CONTINUE:L
;;; Effect: at L; stack unchanged; VAL:  [[ e ]]E

EVAL-DISPATCH
 (branch (self-evaluating? (fetch exp)) EV-SELF-EVAL)
 (branch (global-variable? (fetch exp)) EV-GLOBAL)
 (branch (define? (fetch exp))          EV-DEFINE)
 (branch (quoted? (fetch exp))          EV-QUOTE)
 (branch (lookup? (fetch exp))          EV-LOOKUP)
 (branch (lambda? (fetch exp))          EV-LAMBDA)
 (branch (letrec? (fetch exp))          EV-LETREC)
 (branch (if? (fetch exp))              EV-IF)
 (branch (application? (fetch exp))     EV-APPLICATION)
 (goto UNKNOWN-EXPRESSION-TYPE-ERROR)

; ----------------------------------------------------------------

UNKNOWN-EXPRESSION-TYPE-ERROR
  (perform (user-print 'unknown-expression-type-error))
  (perform (user-print (fetch exp)))
  (goto STOP)

;;; ****************************************************************
;;; Numbers, strings, etc.
EV-SELF-EVAL
  (assign val (fetch exp))
  (goto (fetch continue))

;;; ****************************************************************
;;; Definition of and lookup of global variables

EV-GLOBAL
  (assign val (lookup-global (fetch exp)))
  (goto (fetch continue))

EV-DEFINE
  (save continue)

  (assign exp (cdr (fetch exp)))
  (assign fun (car (fetch exp)))       ; x from (DEFINE x e)
  (save fun)
  (assign exp (cdr (fetch exp)))
  (assign exp (car (fetch exp)))       ; e from (DEFINE x e)
  (assign env the-empty-environment)
  (assign continue DEFINE-EXPR-DONE)
  (goto EVAL-DISPATCH)
DEFINE-EXPR-DONE
  (restore fun)                        ; x from (DEFINE x e)
  (perform (define-global! (fetch fun) (fetch val)))
  (assign val (fetch fun))

  (restore continue)
  (goto (fetch continue))

;;; ****************************************************************
EV-QUOTE
  (assign val (cdr (fetch exp)))
  (assign val (car (fetch val)))
  (goto (fetch continue))

;;; ****************************************************************
;;; Lookup lambda-bound variable in environment.
;;; Expression is of form (LOOKUP frame-number offset)
EV-LOOKUP
  (assign exp (find-frame-cell (fetch exp) (fetch env)))
  (get-I-cell val (fetch exp))
  (goto (fetch continue))

;;; ****************************************************************
EV-LAMBDA
  (assign val (make-procedure (fetch exp) (fetch env)))
  (goto (fetch continue))

;;; ****************************************************************
;;; (LETREC (e1 .. eN) b1 .. bM)

EV-LETREC
  (save continue)

;;; break up the expression into its parts
  (assign unev (cdr (fetch exp)))    ; UNEV: ((e1 .. eN) b1 .. bM)
  (assign exp  (cdr (fetch unev)))   ; EXP: (b1 .. bM)
  (assign unev (car (fetch unev)))   ; UNEV: (e1 .. eN)

;;; build a frame in argl, and a corresponding arg expression list in FUN
  (assign argl nil)
  (assign fun nil)
EV-LETREC-FRAME-BUILD-LOOP
  (branch (null? (fetch unev)) EV-LETREC-BUILD-ENV)

  (assign val (make-I-cell))
  (assign argl (cons (fetch val) (fetch argl)))
  (assign val (car (fetch unev)))
  (assign fun (cons (fetch val) (fetch fun)))

  (assign unev (cdr (fetch unev)))
  (goto EV-LETREC-FRAME-BUILD-LOOP)

;;; extend the environment with this frame
EV-LETREC-BUILD-ENV
  (assign env (adjoin-frame (fetch argl) (fetch env)))

;;; spawn off the arguments, using this new environment
EV-LETREC-SPAWN-LOOP
  (branch (null? (fetch argl)) EV-LETREC-BODY)

  (assign val nil)                                 ; VAL: nil

  (assign unev (car (fetch argl)))                 ; a I-cell
  (assign val (cons (fetch unev) (fetch val)))     ; VAL: I-cell

  (assign val (cons (fetch env) (fetch val)))      ; VAL: E, I-cell

  (assign unev (car (fetch fun)))                  ; e
  (assign val (cons (fetch unev) (fetch val)))     ; VAL: e, E, I-cell

  (assign val (cons EVAL-ARG (fetch val)))         ; VAL: EVAL-ARG, e, E, I-cell
  (spawn (fetch val))

  (assign argl (cdr (fetch argl)))
  (assign fun (cdr (fetch fun)))
  (goto EV-LETREC-SPAWN-LOOP)

;;; EXP: body exprs.  ENV: new env. STACK: continuation
EV-LETREC-BODY
  (assign unev (fetch exp))
  (goto EVAL-SEQUENCE)

;;; ****************************************************************
EV-APPLICATION
  (save continue)
  (assign unev (cdr (fetch exp)))
  (assign exp  (car (fetch exp)))
  (assign argl nil)

SPAWN-ARGS-LOOP
  (branch (null? (fetch unev)) EVAL-OP)

;;; --- Spawn an argument; VAL and FUN are used as temporaries
  (assign val  (make-I-cell))                      ; a I-cell
  (assign argl (cons (fetch val) (fetch argl)))
  (assign fun  (car (fetch unev)))                 ; the first unevaluated argument

  (assign val (cons (fetch val) nil))              ; VAL: (I-cell)
  (assign val (cons (fetch env) (fetch val)))      ; VAL: (env I-cell)
  (assign val (cons (fetch fun) (fetch val)))      ; VAL: (exp env I-cell)
  (assign val (cons EVAL-ARG (fetch val)))         ; VAL: (EVAL-ARG exp env I-cell)
  (spawn (fetch val))
;;; --- Spawned.
  (assign unev (cdr (fetch unev)))
  (goto SPAWN-ARGS-LOOP)

EVAL-OP
  (save argl)
  (assign continue EVAL-OP-DONE)
  (goto EVAL-DISPATCH)

EVAL-OP-DONE
  (assign fun (fetch val))
  (restore argl)
  (goto APPLY-DISPATCH)

;;; ****************************************************************
;;; Spawned argument-evaluation begins here.
;;; Assume: stack: (exp env I-cell)
;;; Effect: stop after storing eval(exp, env) in I-cell

EVAL-ARG
  (restore exp)
  (restore env)
  (assign continue SET-VALUE)
  (goto EVAL-DISPATCH)
SET-VALUE
  (restore exp)
  (set-I-cell! (fetch exp) (fetch val))
  (goto STOP)

;;; ****************************************************************
;;; The apply function
;;; Assumes: FUN: a procedure; ARGL: a frame ; STACK: L
;;; Effect:  at L; stack popped; VAL: value of application of proc to args in frame

APPLY-DISPATCH
  (branch (primitive-procedure? (fetch fun))      PRIMITIVE-APPLY)
  (branch (compound-procedure? (fetch fun))       COMPOUND-APPLY)
  (goto UNKNOWN-PROCEDURE-TYPE-ERROR)

; ----------------------------------------------------------------

UNKNOWN-PROCEDURE-TYPE-ERROR
  (perform (user-print 'unknown-procedure-type-error))
  (perform (user-print (fetch fun)))
  (goto STOP)

;;; ****************************************************************

PRIMITIVE-APPLY
  (branch (car?      (fetch fun)) APPLY-CAR)
  (branch (cdr?      (fetch fun)) APPLY-CDR)
  (branch (cons?     (fetch fun)) APPLY-CONS)

  (branch (atom??    (fetch fun)) APPLY-ATOM?)
  (branch (null??    (fetch fun)) APPLY-NULL?)
  (branch (truncate? (fetch fun)) APPLY-TRUNCATE)

  (branch (eq??      (fetch fun)) APPLY-EQ?)
  (branch (+?        (fetch fun)) APPLY-PLUS)
  (branch (-?        (fetch fun)) APPLY-MINUS)
  (branch (*?        (fetch fun)) APPLY-TIMES)
  (branch (/?        (fetch fun)) APPLY-DIVIDE)
  (branch (<?        (fetch fun)) APPLY-LESS-THAN)
  (branch (>?        (fetch fun)) APPLY-GREATER-THAN)
  (branch (=?        (fetch fun)) APPLY-=)
  (goto UNKNOWN-PRIMITIVE-ERROR)

; ----------------------------------------------------------------

UNKNOWN-PRIMITIVE-ERROR
  (perform (user-print 'unknown-primitive-error))
  (perform (user-print (fetch fun)))
  (goto STOP)

;;; ----------------
APPLY-CAR
  ; get and wait for the cons cell
  (assign exp (car (fetch argl)))
  (get-I-cell val (fetch exp))
  ; get and wait for the CAR
  (assign val (car (fetch val)))
  (get-I-cell val (fetch val))

  (restore continue)
  (goto (fetch continue))

APPLY-CDR
  ; get and wait for the cons cell
  (assign exp (car (fetch argl)))
  (get-I-cell val (fetch exp))
  ; get and wait for the CDR
  (assign val (cdr (fetch val)))
  (get-I-cell val (fetch val))

  (restore continue)
  (goto (fetch continue))

APPLY-CONS
  ; return the CONS of the two I-cells in the frame
  ; i.e., don't wait for either car or cdr to be computed.
  (assign val (car (fetch argl)))
  (assign exp (cdr (fetch argl)))
  (assign exp (car (fetch exp)))
  (assign val (cons (fetch exp) (fetch val)))
  (restore continue)
  (goto (fetch continue))

;;; ----------------
;;; Monadic functions

APPLY-ATOM?
  (assign exp (car (fetch argl)))
  (get-I-cell val (fetch exp))
  (assign val (atom? (fetch val)))
  (restore continue)
  (goto (fetch continue))

APPLY-NULL?
  (assign exp (car (fetch argl)))
  (get-I-cell val (fetch exp))
  (assign val (null? (fetch val)))
  (restore continue)
  (goto (fetch continue))

APPLY-TRUNCATE
  (assign exp (car (fetch argl)))
  (get-I-cell val (fetch exp))
  (assign val (truncate (fetch val)))
  (restore continue)
  (goto (fetch continue))

;;; ----------------
;;; Dyadic functions

APPLY-EQ?
  (assign continue APPLY-EQ?-GOT-ARGS)
  (goto WAIT-FOR-TWO-ARGS)
APPLY-EQ?-GOT-ARGS
  (assign val (eq? (fetch exp) (fetch val)))
  (restore continue)
  (goto (fetch continue))

APPLY-PLUS
  (assign continue APPLY-PLUS-GOT-ARGS)
  (goto WAIT-FOR-TWO-ARGS)
APPLY-PLUS-GOT-ARGS
  (assign val (+ (fetch exp) (fetch val)))
  (restore continue)
  (goto (fetch continue))

APPLY-MINUS
  (assign continue APPLY-MINUS-GOT-ARGS)
  (goto WAIT-FOR-TWO-ARGS)
APPLY-MINUS-GOT-ARGS
  (assign val (- (fetch exp) (fetch val)))
  (restore continue)
  (goto (fetch continue))

APPLY-TIMES
  (assign continue APPLY-TIMES-GOT-ARGS)
  (goto WAIT-FOR-TWO-ARGS)
APPLY-TIMES-GOT-ARGS
  (assign val (* (fetch exp) (fetch val)))
  (restore continue)
  (goto (fetch continue))

APPLY-DIVIDE
  (assign continue APPLY-DIVIDE-GOT-ARGS)
  (goto WAIT-FOR-TWO-ARGS)
APPLY-DIVIDE-GOT-ARGS
  (assign val (/ (fetch exp) (fetch val)))
  (restore continue)
  (goto (fetch continue))

APPLY-LESS-THAN
  (assign continue APPLY-LESS-THAN-GOT-ARGS)
  (goto WAIT-FOR-TWO-ARGS)
APPLY-LESS-THAN-GOT-ARGS
  (assign val (< (fetch exp) (fetch val)))
  (restore continue)
  (goto (fetch continue))

APPLY-GREATER-THAN
  (assign continue APPLY-GREATER-THAN-GOT-ARGS)
  (goto WAIT-FOR-TWO-ARGS)
APPLY-GREATER-THAN-GOT-ARGS
  (assign val (> (fetch exp) (fetch val)))
  (restore continue)
  (goto (fetch continue))

APPLY-=
  (assign continue APPLY-=-GOT-ARGS)
  (goto WAIT-FOR-TWO-ARGS)
APPLY-=-GOT-ARGS
  (assign val (= (fetch exp) (fetch val)))
  (restore continue)
  (goto (fetch continue))

WAIT-FOR-TWO-ARGS
  (assign exp (car (fetch argl)))
  (get-I-cell val (fetch exp))
  (assign exp (cdr (fetch argl)))
  (assign exp (car (fetch exp)))
  (get-I-cell exp (fetch exp))
  (goto (fetch continue))

;;; ****************************************************************
COMPOUND-APPLY
  (assign env (procedure-environment (fetch fun)))
  (assign env (adjoin-frame (fetch argl) (fetch env)))
  (assign unev (procedure-body (fetch fun)))
  (goto EVAL-SEQUENCE)

;;; ****************************************************************
;;; Eval-sequence is the same as sequential case

EVAL-SEQUENCE
  (assign exp (car (fetch unev)))
  (assign val (cdr (fetch unev)))
  (branch (null? (fetch val)) LAST-EXP)
  (save unev)
  (save env)
  (assign continue EVAL-SEQUENCE-CONTINUE)
  (goto EVAL-DISPATCH)

EVAL-SEQUENCE-CONTINUE
  (restore env)
  (restore unev)
  (assign unev (cdr (fetch unev)))
  (goto EVAL-SEQUENCE)

LAST-EXP
  (restore continue)
  (goto EVAL-DISPATCH)

;;; ****************************************************************
;;; Evaluation of conditionals is the same as before

EV-IF
  (save continue)
  (assign continue EV-IF-DECIDE)
  (assign unev (cdr (fetch exp)))
  (assign exp (car (fetch unev)))
  (assign unev (cdr (fetch unev)))
  (save env)
  (save unev)
  (goto EVAL-DISPATCH)

EV-IF-DECIDE
  (restore unev)
  (restore env)
  (restore continue)
  (branch (null? (fetch val)) EV-ELSE-PART)
EV-THEN-PART
  (assign exp (car (fetch unev)))
  (goto EVAL-DISPATCH)
EV-ELSE-PART
  (assign exp (cdr (fetch unev)))
  (assign exp (car (fetch exp)))
  (goto EVAL-DISPATCH)

;;; ****************************************************************
;;; End of controller sequence

STOP

))

;;; ****************************************************************
;;; A particular non-strict multiprocessor called NSMP

(define nsmp (make-multiprocessor non-strict-controller-code))

;;; ****************************************************************
