;;; 6.001 Controller code for explicit-control evaluator with parallelism constructs.
;;; 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 instruction:

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

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

(define 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 (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)))
  (assign val (frame-cell-value (fetch exp)))
  (goto (fetch continue))

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

;;; ****************************************************************
EV-APPLICATION
  (save continue)

;;; --- Spawn arguments; VAL, FUN and CONTINUE are used as temporaries
  (assign val (length (fetch exp)))   ; N, length of application
  (assign val (cons (fetch val) nil)) ; first cell of frame (with counter)
  (save val)
  (assign fun (fetch stack))          ; keep common part of stack in FUN

  (assign unev (cdr (fetch exp)))
  (assign exp  (car (fetch exp)))
  (assign argl nil)                   ; the argument list

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

;;; --- Spawn an argument
  (assign val  (make-frame-cell))                  ; a frame cell
  (assign argl (cons (fetch val) (fetch argl)))    ; cons it into arg list
  (save val)                                       ; save frame cell
  (save env)                                       ; save environment
  (assign val (car (fetch unev)))                  ; an argument
  (save val)                                       ; save arg
  (assign continue EVAL-ARG)                       ; save
  (save continue)                                  ;   EVAL-ARG label
  (spawn (fetch stack))
;;; --- Spawned.

  (assign stack (fetch fun))                       ; restore stack to common part
  (assign unev (cdr (fetch unev)))                 ; remaining args
  (goto SPAWN-ARGS-LOOP)

;;; evaluation of all arguments spawned
EVAL-OP
  (restore unev)                                 ; the counter cell
  (save unev)
  (assign val (make-frame-cell))                 ; frame cell for e1
  (assign argl (cons (fetch val) (fetch argl)))  ; cons into arg list
  (perform (set-cdr! (fetch unev) (fetch argl))) ; link counter cell to rest of frame
  (save val)
  (assign continue SET-VALUE)
  (goto EVAL-DISPATCH)

;;; ****************************************************************
;;; Each spawned argument-evaluation begins here.
;;; Assume: stack: (exp env frame-cell frame-handle ...)
;;; Effect: eval(exp, env) into val, at SET-VALUE

EVAL-ARG
  (restore exp)
  (restore env)
  (assign continue SET-VALUE)
  (goto EVAL-DISPATCH)

;;; Here after evaluating each piece of an application form (arg, operator)
;;; Assume: VAL: v  STACK: (frame-cell frame ...)
;;; Effect: Store v in frame-cell, pop stack.
;;;         Decrement arg-count in frame. If not 0, stop.
;;;         Else goto GET-READY-TO-APPLY
SET-VALUE
  (restore exp)
  (perform (set-frame-cell-value! (fetch exp) (fetch val)))
  (restore exp)
  (assign val (decr-arg-count-and-fetch! (fetch exp)))
  (branch (zero? (fetch val)) READY-TO-APPLY)
  (goto STOP)

;;; Here after last component of application has been done.
;;; Assume: EXP: frame   STACK: continuation ...

READY-TO-APPLY
  (assign exp (cdr (fetch exp)))
  (assign fun (car (fetch exp)))
  (assign fun (frame-cell-value (fetch fun)))
  (assign argl (cdr (fetch exp)))
  (goto APPLY-DISPATCH)

;;; ****************************************************************
;;; 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 cons cell
  (assign exp (car (fetch argl)))
  (assign val (frame-cell-value (fetch exp)))
  ; get the CAR
  (assign val (car (fetch val)))
  (assign val (frame-cell-value (fetch val)))

  (restore continue)
  (goto (fetch continue))

APPLY-CDR
  ; get cons cell
  (assign exp (car (fetch argl)))
  (assign val (frame-cell-value (fetch exp)))
  ; get the CDR
  (assign val (cdr (fetch val)))
  (assign val (frame-cell-value (fetch val)))

  (restore continue)
  (goto (fetch continue))

APPLY-CONS
  ; return the CONS of the two frame-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)))
  (assign val (frame-cell-value (fetch exp)))
  (assign val (atom? (fetch val)))
  (restore continue)
  (goto (fetch continue))

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

APPLY-TRUNCATE
  (assign exp (car (fetch argl)))
  (assign val (frame-cell-value (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)))
  (assign val (frame-cell-value (fetch exp)))
  (assign exp (cdr (fetch argl)))
  (assign exp (car (fetch exp)))
  (assign exp (frame-cell-value (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 strict multiprocessor called SMP

(define smp (make-multiprocessor strict-controller-code))

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