Page Numbers: Yes X: 510 Y: 10.42" First Page: 1
Margins: Top: 1.0" Bottom: 1.5"
Heading:
3-LISP DEUS-EX-MACHINA PROCESSOR
;;; -*- October 22, 1982 10:58 AM -*-
;;; Deus ex machina for the October 1st reflective processor
;;; ========================================================
;;; The following is a sketch of a 3-LISP implementation in (a subset of) 3-LISP. The
;;; language being implemented is the version of 3-LISP whose reflective processor can
;;; be found in [phylkum]<3-lisp>documentation>processor.bravo.
;;; How to read this program:
;;; The procedures that have familiar names (e.g. normalize, reduce) should be
;;; understood from the same point of view as the procedures in the reflective
;;; processor.
;;; "Tower level"?
;;; This phrase is sometimes used to refer to the 3-LISP being implemented.
;;; What is boldface for?
;;; Boldface is used to refer to standard objects of the implementation language
;;; (e.g. define, lambda, simple, let, block, if, cond, scons, +, and a couple more).
;;; All other names are used to refer to implementation level objects that are specific
;;; to the implememtation of the tower; i.e., "1st" refers to the usual 3-LISP kernel
;;; procedure, whereas "1st" refers to the 3-LISP procedure that implements the tower’s
;;; version of it.
;;; What does "@" signify?
;;;When a name begins in "@", it has to do with some sort of implementation
;;; level object that is not the representation of some part of the tower. For example,
;;; "@reflective" is a procedure that returns an implementation-level boolean; "@fun"
;;; is bound to an implementation-level function designator, whereas "fun" would be bound
;;; to a tower-level function closure (i.e. an implementation level representation of a
;;; tower-level closure).
;;; What is the subset of 3-LISP used by the implementation?
;;; It is important to note that this implementation uses only a subset of the capabilities
;;; of the implementation language. This subset is semantially flat and first order; it need
;;; not support tail recursion; all variables used are either local to a procedure or global
;;; to everything.
;;; Why "deus ex machina"?
;;; This term for the implementation seemed appropriate because, from within a 3-LISP
;;; tower, any complete description of the system would have to recognize the existence
;;;of an invisible supreme being that knows how to reduce the primitives.
;;; How does this implementation compare to the one in the thesis?
;;;Very similar. Dialects implemented are quite similar. All error checking has been
;;; removed. Reflective continuations are handled correctly. Token identify of all
;;;processor-created structures consistent with reflective processor. Reducers/appliers
;;;are associated with closures (avoiding costly lookups).
;;; What are "reducers"?
;;; A "reducer" is an implementation level procedures that is associated with a tower
;;; level closure. When the processor wants to reduce a simple closure it calls the
;;; reducer passing it all relevant information. The reducer decides how the reduction
;;; will be done: the slow way (expand the closure), a fast way (shift down), or like
;;; a primitive.
;;; How are reflective continuations handled?
;;; Global variables
;;; ================
;;;
;;; There are a small number of global variables that are modified by the running implementation.
;;; They are:
;;; @continuation-stack --- A sequence of continuations for each level above the current level.
;;; @current-level --- Level number at which the implementation is currently running.
;;; @next-fun-to-apply --- Pseudo-parameter to @DEUS.
;;; @next-args-to-apply --- Pseudo-parameter to @DEUS.
;;; @next-result --- Pseudo-result from @DEUS.
;;; @last-fun-applied --- Last function applied (in case of reflective continuations).
;;; @last-args-applied --- Last argument sequence.
;;; @DEUS
;;; =====
;;;
;;; @DEUS is the driving loop of this implementation of a 3-LISP tower. Given
;;; function and argument designators in the pseudo-parameters @next-fun-to-apply and
;;; @next-args-to-apply, the function is applied to these arguments.
;;; The receipt of a result means that there is no more work to be done at
;;; the current level; accordingly, the implementation shifts up and hands this result
;;; to a continuation obtained by popping the continuation stack.
(define @DEUS
(lambda simple []
(block (set @last-fun-applied @next-fun-to-apply)
(set @last-args-applied @next-args-to-apply)
(let [[@status ((@applier @next-fun-to-apply) @next-fun-to-apply @next-args-to-apply)]]
(if (= @status ’done)
(block (set @next-fun-to-apply (@overhead-cont))
(set @next-args-to-apply (scons (up @next-result)))
(@shift-up)
@deus))]
(@deus))))))
;;; @GO
;;; ===
;;;
;;; @GO applies its first argument to the rest of its arguments; i.e. it does an
;;; object language ((1st args) . (rest args));. First, the object language
;;; closure may be reflective, in which case we will shift up and continue processing
;;; from the last processor procedure we entered. Second, not wanting to use the
;;; tail-recursive facet of the implementation language, we will have to return
;;; (into @deus) with an indication that there is still more work to do at the
;;; same level.
(define @GO
(lambda simple @args
(if (@reflective (up (1st @args)))
(@shift-expand-closure @last-fun-applied @last-args-applied)
(block (set @next-fun-to-apply (1st @args))
(set @next-args-to-apply (rest @args))
’continue))))
;;; @GO-SIMPLE
;;; ==========
;;;
;;; @GO-SIMPLE is similar to @GO except that reflective closures are treated as if they
;;; were simple.
(define @GO-SIMPLE
(lambda simple @args
(block (set @next-fun-to-apply (1st @args))
(set @next-args-to-apply (rest @args))
’continue))))
;;; @RETURN
;;; =======
;;;
;;; Return to the main loop with a result sequence.
(define @RETURN
(lambda simple @args
(block (set @next-result @args)
’done)))
;;; @SHIFT-EXPAND-CLOSURE
;;; =====================
;;;
(define @SHIFT-EXPAND-CLOSURE
(lambda simple [fun @args]
(let [[cont (@overhead-cont)]]
(block (@shift-up)
(@expand-closure (up fun) (up (@make-sequence @args)) cont)))))
;;; @EXPAND-CLOSURE
;;; ===============
;;;
(define @EXPAND-CLOSURE
(lambda simple [proc! args! cont]
(@go normalize-closure
(body proc!)
(bind (pattern proc!) args! (down (cenv proc!)))
cont)))
;;; NORMALIZE
;;; =========
;;;
(define NORMALIZE
(lambda simple [exp env cont]
(cond [(@normal exp) (@go cont exp)]
[(@atom exp)
(if (@reflective (up cont))
(@go cont)
(@go cont (binding exp env)))]
[(@rail exp) (@go normalize-rail-closure exp env cont)]
[(@pair exp) (@go reduce-closure (car exp) (cdr exp) env cont)])))
;;; REDUCE
;;; ======
;;;
(define REDUCE
(lambda simple [proc args env cont]
(@go normalize-closure proc env (make-C0 proc args env cont))))
;;; C0
;;; ==
;;;
(define C0
(lambda simple [proc! C0-cont]
(let [[args (args-from-C0 C0-cont)]
[env (env-from-C0 C0-cont)]
[cont (cont-from-C0 C0-cont)]]
(if (@reflective proc!)
(@go (down (de-reflect proc!)) args env cont)
(@go normalize-closure args env (make-C1 proc! C0-cont))))))
;;; C1
;;; ==
;;;
(define C1
(lambda simple [args! C1-cont]
(let [[proc! (proc!-from-C1 C1-cont)]
[cont (cont-from-C1 C1-cont)]]
((@reducer proc!) proc! args! cont))))
;;; NORMALIZE-RAIL
;;; ==============
;;;
(define NORMALIZE-RAIL
(lambda simple [rail env cont]
(if (@empty rail)
(@go cont (rcons))
(@go normalize-closure (1st rail) env (make-C2 rail env cont)))))
;;; C2
;;; ==
;;;
(define C2
(lambda simple [element! C2-cont]
(let [[rail (rail-from-C2 C2-cont)]
[env (env-from-C2 C2-cont)]]
(@go normalize-rail-closure (rest rail) env (make-C3 element! C2-cont)))))
;;; C3
;;; ==
;;;
(define C3
(lambda simple [rest! C3-cont]
(let [[cont (cont-from-C3 C3-cont)]
[element! (element!-from-C3 C3-cont)]]
(if (@reflective (up cont))
(@go cont)
(@go cont (prep element! rest!))))))
;;; End of the reflective processor proper.
;;; =======================================================================================
;;; The following "compiled" object language procedures merely make for a speedier
;;; implementation but are otherwise unnecessary.
;;; Conditionals
;;; ============
;;;
(define IF
(lambda simple [premise then else env cont]
(@go normalize-closure premise env (make-CIF premise then else env cont))))
(define CIF
(lambda simple [premise! CIF-cont]
(let [[then (then-from-CIF CIF-cont)]
[else (else-from-CIF CIF-cont)]
[env (env-from-CIF CIF-cont)]
[cont (cont-from-CIF CIF-cont)]]
(@go normalize-closure (ef (down premise!) then else) env cont))))
(define COND
(lambda simple [clauses env cont]
(@go normalize-closure (1st (1st clauses)) env (make-CCOND clauses env cont))))
(define CCOND
(lambda simple [premise! CCOND-cont]
(let [[clauses (clauses-from-CCOND CCOND-cont)]
[env (env-from-CCOND CCOND-cont)]
[cont (cont-from-CCOND CCOND-cont)]]
(cond [(@= (down premise!) $T-value) (@go normalize-closure (2nd (1st clauses)) env cont)]
[(@= (down premise!) $F-value) (@go cond (rest clauses) env cont)]))))
;;; BLOCK
;;; =====
;;;
(define BLOCK
(lambda simple [clauses env cont]
(cond [(@empty clauses) (@go cont)]
[(@unit clauses) (@go normalize-closure (1st clauses) env cont)]
[$T (@go normalize-closure (1st clauses) env (make-CBLOCK clauses env cont))])))
(define CBLOCK
(lambda simple [CBLOCK-cont]
(let [[clauses (clauses-from-CBLOCK CBLOCK-cont)]
[env (env-from-CBLOCK CBLOCK-cont)]
[cont (cont-from-CBLOCK CBLOCK-cont)
(@go block-closure (rest clauses) env cont))))
;;; AND and OR
;;; ==========
;;;
(define AND
(lambda simple [args env cont]
(if (@empty args)
(@go cont $T-handle)
(@go normalize-closure (1st args) env (make-CAND args env cont)))))
(define CAND
(lambda simple [premise! CAND-cont]
(let [[args (args-from-CAND CAND-cont)]
[env (env-from-CAND CAND-cont)]
[cont (cont-from-CAND CAND-cont)]]
(cond [(@= (down premise!) $T-value) (@go and-closure (rest args) env cont)]
[(@= (down premise!) $F-value) (@go cont $F-handle)]))))
(define OR
(lambda simple [args env cont]
(if (@empty args)
(@go cont $F-handle)
(@go normalize-closure (1st args) env (make-COR args env cont)))))
(define COR
(lambda simple [premise! COR-cont]
(let [[args (args-from-COR COR-cont)]
[env (env-from-COR COR-cont)]
[cont (cont-from-COR COR-cont)]]
(cond [(@= (down premise!) $F-value) (@go or-closure (rest args) env cont)]
[(@= (down premise!) $T-value) (@go cont $T-handle)]))))
;;; Setting of variables
;;; ====================
;;;
(define SET
(lambda simple [var binding env cont]
(@go normalize-closure binding env (make-CSET var binding env cont))))
(define CSET
(lambda simple [binding! CSET-cont]
(let [[var (var-from-CSET CSET-cont)]
[env (env-from-CSET CSET-cont)]
[cont (cont-from-CSET CSET-cont)]]
(block (rebind var binding! env)
(@go cont))))))
;;; ==============================================================================
;;; @CONTINUATION-STACK
;;; ===================
;;;
;;; In principle there is a distinct continuation for each of the infinite number of reflective
;;; levels. However, we do not store them all. We just keep them for all levels between the
;;; current level and the highest level ever reached. That’s what @CONTINUATION-STACK is for.
;;; @OVERHEAD-CONT
;;; ==============
;;;
;;; If the implementation is running at level n then @OVERHEAD-CONT will return the
;;; level n+1 continuation that accuratly reflects what’s pending at that level. If we’ve
;;; never been to this level before, pull one out of thin air.
(define @OVERHEAD-CONT
(lambda simple []
(if (empty @continuation-stack)
(@new-top-level-cont (+ @current-level 1))
(1st @continuation-stack))))
;;; @SHIFT-UP
;;; =========
;;;
;;; Pretend that we are now playing reflective processor at one level higher than
;;; we were just a moment ago. Adjust the continuation stack so that it accurately
;;; reflects our new stance.
(define @SHIFT-UP
(lambda simple []
(if (empty @continuation-stack)
(set @current-level (+ @current-level 1))
(block (set @current-level (+ @current-level 1))
(set @continuation-stack (rest @continuation-stack))))))
;;; @SHIFT-DOWN
;;; ===========
;;;
;;; Pretend that we are going to play reflective processor at one level lower than
;;; we were a moment ago. Save the continuation for our former level on the
;;; continuation stack. Important note: the continuation saved must not be reflective
;;; since that would make life very difficult for @DEUS.
(define @SHIFT-DOWN
(lambda simple [cont]
(block (set @continuation-stack (prep cont @continuation-stack))
(set @current-level (- @current-level 1)))))
;;; @GENESIS
;;; ========
;;;
;;; @GENESIS starts things off at level 2 with an empty continuation stack ready to enter
;;; READ-NORMALIZE-PRINT with [1 global] as the argument sequence; i.e. as if the following
;;; expression had been entered:
;;;
;;; 2> (read-normalize-print 1 global)
;;;
;;; This will soon provoke the "1> " prompt and read an expression from the user.
(define @GENESIS
(lambda simple []
(block (set @continuation-stack (scons))
(set @current-level 2)
(set @next-fun-to-apply read-normalize-print-closure)
(set @next-args-to-apply (scons one-value global))
(@deus))))
;;; @NEW-TOP-LEVEL-CONT
;;; ===================
;;;
;;; The tower is allegedly initialized with incantations of the form:
;;;
;;; #> (read-normalize-print # global)
;;; .
;;; .
;;; 3> (read-normalize-print 2 global)
;;; 2> (read-normalize-print 1 global)
;;;
;;; This would mean that the great flurry of activity at level 1 is driven by the call to
;;; NORMALIZE inside READ-NORMALIZE-PRINT, whose definition is:
;;;
;;;(define READ-NORMALIZE-PRINT
;;;(lambda simple [level env]
;;;(block (prompt level)
;;; (map reply (normalize (read) env id*))
;;; (read-normalize-print level env))))
;;;
;;; Viewed from one level up, there is always a predictable continuation structure; this procedure
;;; creates these continuations. In what follows, r-n-p-1 refers to the second tail of the rail
;;; [reply (normalize ...)], r-n-p-2 refers to the first tail of it, and r-n-p-3
;;; refers to the first tail of [(prompt ...) (map ...) (read-normalize-print ...)]. These
;;; three variables must be given their values at the beginning of time, based on the
;;; initial body of READ-NORMALIZE-PRINT.
(define @NEW-TOP-LEVEL-CONT
(lambda simple [@level]
(let [[xenv (prep (scons (up level-atom)
(up (make-number @level)))
(prep (scons (up env-atom) (up global))
global))]]
(make-C2 (up r-n-p-1) xenv
(make-C3 (up reply-closure)
(make-C2 (up r-n-p-2) xenv
(make-C1 (up map-closure)
(make-C0 (up map-atom) (up r-n-p-2) xenv
(make-CBLOCK (up r-n-p-3) xenv
id*-closure))))))))))
;;; Tables of reducers and appliers
;;; ===============================
;;;
;;; With each object language closure we associate a "reducer" and an "applier" ---
;;; implementation language procedures used to do reduce/apply that closure.
;;; @GLOBAL-PROCEDURE is used to create a build-in closure and add a binding to the
;;; shared global environment of the object language. Associated with the closure will
;;; be a pair of (implementation level) procedures called the "reducer" and the "applier".
;;; The "reducer" for a closure is called whenever the processor goes to reduce this closure
;;; with some arguments (see C1). The "applier" for a closure is called whenever the
;;; processor wants to apply the function designated by this closure. The level-shifting
;;; aspects of the implementation are, for the most part, taken care of in these procedures.
;;; We will not give definitions for all of the built-in procedures since this would be
;;; quite unenlightening; instead, we will give some examples and indicate which procedures
;;; fit each mold.
;;; Example 1: An "uncompiled" procedure such as READ-NORMALIZE-PRINT.
(set read-normalize-print-closure
(@global-procedure [’simple] ’n/a
"READ-NORMALIZE-PRINT" "[level env]"
"(block (prompt level)
(map reply (normalize (read) env id*))
(read-normalize-print level env))" ))
; Reducer: @expand-closure
; Applier: @shift-expand-closure
; Similar: PROMPT, REPLY, Z.
;;; Example 2: A primitive such as + that speads its arguments.
(set +-closure
(@global-procedure [’primitive ’simple ’protected ’known] +
"+" "[x y]" "(+ x y)" ))
; Reducer:
(lambda simple [proc! args! cont]
(if (@reflective (up cont))
(@go cont)
(@go cont (up (scons (+ (1st (down args!)) (2nd (down args!))))))))
; Applier:
(lambda simple [fun @args]
(@return (+ (1st @args) (2nd @args))))
; Similar: All primitives except RCONS and SCONS.
;;; Example 3: A primitive such as RCONS that doesn’t spread its arguments.
(set rcons-closure
(@global-procedure [’primitive ’simple ’protected ’known] +
"RCONS" "x" "(rcons . x)" ))
; Reducer:
(lambda simple [proc! args! cont]
(if (@reflective (up cont))
(@go cont)
(@go cont (up (scons (rcons . (spread (down args!))))))))
; Applier:
(lambda simple [fun @args]
(@return (rcons . @args)))
; Similar: SCONS.
;;; Example 4: A simple kernel procedure such as NORMALIZE.
(set normalize-closure
(@global-procedure [’simple ’protected ’known ’kernel] normalize
"NORMALIZE" "[exp env cont]"
"(cond [(normal exp) (cont exp)]
[(atom exp) (cont (binding exp env))]
[(rail exp) (normalize-rail exp env cont)]
[(pair exp) (reduce (car exp) (cdr exp) env cont)])" ))
; Reducer:
(lambda simple [proc! args! cont]
(if (and (not (@reflective cont)) (@3-args! args!))
(block (@shift-down cont)
(@go-simple (down proc!) (1st (down args!)) (2nd (down args!)) (3rd (down args!))))
(@expand-closure proc! args! cont)))
; Applier:
(lambda simple [fun @args]
(if (@3-args @args)
(normalize (1st @args) (2nd @args) (3rd @args))
(@shift-expand-closure fun @args)))
; Similar: REDUCE, NORMALIZE-RAIL, NORMAL,NORMAL-RAIL, PRIMITIVE, BINDING, BIND, REFLECTIVE,
; DE-REFLECT, 1ST, 2ND, 3RD, REST, EMPTY, UNIT, DOUBLE, ATOM, RAIL, PAIR, NUMERAL,
; HANDLE, BOOLEAN, CHARAT, CLOSURE, NUMBER, SEQUENCE, TRUTH-VALUE, CHARACTER,
; FUNCTION, ID, ID*, VCONS, RPLACT, RPLACN, VECTOR, ABSTRACT, STRUCTURE, MEMBER,
; NOT, SIMPLE, REFLECT, MACRO, REFLECT*, COND*, BLOCK*, AND*, OR*, REBIND.
;;; Example 5: A reflective kernel procedure such as IF.
(set if-closure
(@global-procedure [’reflect ’protected ’known ’kernel] if
"IF" "[[premise then else] env cont]"
"(normalize premise env
(lambda simple [premise!]
(normalize (ef \premise! then else) env cont)))" ))
; Reducer: (note that this reducer is associated with a de-reflected version of the
; closure for IF.)
(lambda simple [proc! args! cont]
(if (and (not (@reflective cont)) (@3-args! args!) (@if-intact proc!))
(block (@shift-down cont)
(@go-simple (down proc!) (1st (down args!)) (2nd (down args!)) (3rd (down args!))))
(@expand-closure proc! args! cont)))
; Applier:
(lamnbda simple [fun @args]
(if (@3/3-args @args)
(if (1st (1st @args)) (2nd (1st @args)) (3rd (1st @args)) (2nd @args) (3rd @args))
(@shift-expand-closure fun @args)))
; Similar: COND, BLOCK, AND, OR, SET.
;;; Example 6: A standard continuation such as C1.
; Reducer:
(lambda simple [proc! args! cont]
(if (and (not (@reflective cont)) (@1-args! args!) (@C1-intact proc!))
(block (@shift-down cont)
(@go-simple (down proc!) (1st (down args!))))
(@expand-closure proc! args! cont)))
; Applier:
(lambda simple [fun @args]
(if (and (@C1-intact (up fun)) (@1-arg @args))
(C1 (1st @args) fun)
(@shift-expand-closure fun @args)))
; Similar: C0, C2, C3, C4, CIF, COR, CAND, CCOND, CSET, CBLOCK.
;;; Example 7: An "uncompiled" kernel procedure such as LAMBDA.
(set lambda-closure
(@global-procedure [’protected ’reflect] ’n/a
"LAMBDA" "[[kind pattern body} env cont]"
"(reduce kind ↑(scons ↑env pattern body) env cont)" ))
; Reducer: @expand-closure
; Applier: @shift-expand-closure
; Similar: DEFINE, Z, LET, LET*.