Permalink
Switch branches/tags
Find file
Fetching contributors…
Cannot retrieve contributors at this time
480 lines (443 sloc) 15 KB
;;; cogen-direct-anf.scm
;;; copyright © 1996-2000 by Peter Thiemann
;;; non-commercial use is free as long as the original copright notice
;;; remains intact
;;;
;;; direct style version of the continuation-based multi-level
;;; compiler generator (with control operators)
;;;
;;; includes the conversion of the residual code to A-normal form
;;; hence performs full context propagation
;;;
(set-scheme->abssyn-let-insertion! #f)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; an implementation using macros
(define-syntax _app
(syntax-rules ()
((_app 0 e ...)
(e ...))
((_app 1 e arg ...)
(_complete-serious e (list arg ...)))
((_app lv e ...)
(_complete (make-residual-generator-ve* '_APP (pred lv) e ...)))))
(define-syntax _app-no-result
(syntax-rules ()
((_app 0 e ...)
(e ...))
((_app 1 e arg ...)
(_complete-serious-no-result e (list arg ...)))
((_app lv e ...)
(_complete-no-result (make-residual-generator-ve* '_APP (pred lv) e ...)))))
(define-syntax _app_memo
(syntax-rules ()
((_app_memo 0 f arg ...)
((f 'VALUE) arg ...))
((_app_memo lv e ...)
(_complete (make-residual-generator-ve* '_APP_MEMO (pred lv) e ...)))))
(define-syntax _lambda
(syntax-rules ()
((_lambda 0 vars vvs bts body)
(lambda vars body))
((_lambda lv vars vvs bts body)
(_lambda-internal lv 'vars vvs bts (lambda vars body)))))
(define (_lambda-internal lv arity vvs bts f)
(let* ((vars (map make-residual-variable (map gensym-local arity)))
(body (reset (apply f vars)))
(l (pred lv))
;; for fvs
(lambda-pp (cons 'LAMBDA vvs))
(dynamics (top-project-dynamic lambda-pp bts))
(compressed-dynamics (remove-duplicates dynamics))
(actual-fvs (map car compressed-dynamics))
;; end for fvs
(generate-lambda
(if (zero? l)
(lambda ()
(make-residual-lambda vars actual-fvs body))
(lambda ()
(let ((new-bts (map pred (map cdr compressed-dynamics))))
(make-residual-generator-vveqe '_LAMBDA l vars
(make-residual-call 'LIST actual-fvs)
new-bts
body))))))
;; (display-line "_lambda-internal " dynamics)
(if *lambda-is-pure*
(generate-lambda)
(_complete ;don't duplicate, experimental
(generate-lambda)))))
(define-syntax _lambda_memo
(syntax-rules ()
((_lambda_memo 0 arity label vvs bts f)
(static-constructor label f vvs bts))
((_lambda_memo arg ...)
(_lambda_memo-internal arg ...))))
(define (_lambda_memo-internal lv arity label vvs bts f)
(address-registry-reset!)
(address-map-reset!)
(let* ((formals (map make-residual-variable (map gensym-local arity)))
(lambda-pp (cons label vvs))
(dynamics (top-project-dynamic lambda-pp bts))
(compressed-dynamics (remove-duplicates dynamics))
(actual-fvs (map car compressed-dynamics))
(clone-map (map (lambda (arg)
(cons arg (if (symbol? arg)
(gensym-local arg)
(gensym-local 'clone))))
actual-fvs))
(cloned-pp (top-clone-with clone-map lambda-pp bts))
(cloned-vvs (cdr cloned-pp))
(new-bts (map pred (map cdr compressed-dynamics)))
(formal-fvs (map cdr clone-map)))
;; (> lv 0)
(_complete
(make-residual-generator-vqqeqe
'_LAMBDA_MEMO
(pred lv)
arity
(gensym 'cls)
(make-residual-call 'LIST actual-fvs)
new-bts
(make-residual-closed-lambda
formal-fvs
'FREE
(make-residual-closed-lambda
formals
'FREE
(reset (apply (apply f cloned-vvs) formals))))))))
;;; formerly:
;;; `(_LAMBDA_MEMO
;;; ,(- lv 1)
;;; ',arity
;;; ',(gensym 'cls)
;;; (LIST ,@actual-fvs)
;;; ',new-bts
;;; (LAMBDA ,formal-fvs
;;; (LAMBDA ,formals
;;; ,(reset (apply (apply f cloned-vvs) formals)))))
(define-syntax _vlambda
(syntax-rules ()
((_vlambda 0 () var body)
(lambda var body))
((_vlambda 0 (fixed-var ...) var body)
(lambda (fixed-var ... . var) body))
((_vlambda lv (fixed-var ...) var body)
(_vlambda-internal lv '(var fixed-var ...)
(lambda (var fixed-var ...) body)))))
(define (_vlambda-internal lv arity f)
(let* ((vars (map make-residual-variable (map gensym-local arity)))
(body (reset (apply f vars)))
(l (pred lv))
(fixed-vars (cdr vars))
(var (car vars)))
(_complete ;don't duplicate, experimental
(if (zero? l)
(make-residual-closed-lambda (append fixed-vars var) '() body)
(make-residual-generator-vvve* '_VLAMBDA l fixed-vars var body)))))
(define-syntax _vlambda_memo
(syntax-rules ()
((_vlambda_memo 0 arity var label vvs bts f)
(static-constructor label f vvs bts))
((_vlambda_memo arg ...)
(_vlambda_memo-internal arg ...))))
(define (_vlambda_memo-internal lv arity var label vvs bts f)
(address-registry-reset!)
(address-map-reset!)
(let* ((fixed-formals (map make-residual-variable (map gensym-local arity)))
(formal (gensym-local var))
(lambda-pp (cons label vvs))
(dynamics (top-project-dynamic lambda-pp bts))
(compressed-dynamics (remove-duplicates dynamics))
(actual-fvs (map car compressed-dynamics))
(clone-map (map (lambda (arg)
(cons arg (if (symbol? arg)
(gensym-local arg)
(gensym-local 'clone))))
actual-fvs))
(cloned-pp (top-clone-with clone-map lambda-pp bts))
(cloned-vvs (cdr cloned-pp))
(new-bts (map pred (map cdr compressed-dynamics)))
(formal-fvs (map cdr clone-map)))
;; (> lv 0)
(let ((lv (- lv 1)))
(_complete
(make-residual-generator-vqqqeqe
'_VLAMBDA_MEMO
lv
arity
var
(gensym 'cls)
(make-residual-call 'LIST actual-fvs)
new-bts
(make-residual-closed-lambda
formal-fvs
'FREE
(make-residual-closed-lambda
(if (zero? lv)
(append fixed-formals formal)
(cons formal fixed-formals))
'FREE
(reset (apply (apply f cloned-vvs) (cons formal fixed-formals))))))))))
;;; was:
;;; `(_VLAMBDA_MEMO
;;; ,lv
;;; ',arity
;;; ',var
;;; ',(gensym 'cls)
;;; (LIST ,@actual-fvs)
;;; ',new-bts
;;; (LAMBDA ,formal-fvs
;;; (LAMBDA ,(if (zero? lv)
;;; (append fixed-formals formal)
;;; (cons formal fixed-formals))
;;; ,(reset (apply (apply f cloned-vvs)
;;; (cons formal fixed-formals))))))
(define-syntax _lambda_poly
(syntax-rules ()
((_lambda_poly 0 arity bts body-level label body)
(poly-constructor
label
'arity
bts body-level
(lambda arity body)
(list 'vector)
(_complete-serious 'vector '()))) ; #### is this right? ---Mike
((_lambda_poly level arity bts body-level label body)
`(_lambda_poly ,(pred level) arity ',(map pred bts) ,(pred body-level) 'label ,body))))
(define-syntax _begin
(syntax-rules (multi-memo _app _op _op-serious)
((_begin 0 bl (multi-memo arg ...) e2)
(begin (multi-memo-no-result arg ...) e2))
((_begin 1 bl (multi-memo arg ...) e2)
(shift k (make-residual-begin (multi-memo-no-result arg ...)
(reset (k e2)))))
((_begin 0 bl (_app arg ...) e2)
(begin (_app-no-result arg ...)
e2))
((_begin 1 bl (_app arg ...) e2)
(shift k (make-residual-begin (_app-no-result arg ...) (reset (k e2)))))
((_begin 0 bl (_op arg ...) e2)
(begin (_op-no-result arg ...) e2))
((_begin 0 bl (_op-serious arg ...) e2)
(begin (_op-serious-no-result arg ...) e2))
((_begin 1 bl (_op arg ...) e2)
(shift k (make-residual-begin (_op-no-result arg ...) (reset (k e2)))))
((_begin 1 bl (_op-serious arg ...) e2)
(shift k (make-residual-begin (_op-serious-no-result arg ...) (reset (k e2)))))
((_begin 0 bl e1 e2)
(begin e1 e2))
((_begin 1 bl e1 e2)
(shift k (make-residual-begin e1 (reset (k e2)))))
((_begin lv bl e1 e2)
(shift k (make-residual-generator-vvee '_BEGIN (pred lv) 0 e1 (reset (k e2)))))))
(define-syntax _ctor_memo
(syntax-rules ()
((_ctor_memo 0 bts #f ctor arg ...)
(static-constructor 'ctor ctor (list arg ...) 'bts))
((_ctor_memo 0 bts #t ctor arg ...)
(hidden-constructor 'ctor ctor (list arg ...) 'bts))
((_ctor_memo lv (bt ...) hidden ctor arg ...)
(_complete
(make-residual-generator-vvvve* '_CTOR_MEMO
(pred lv)
(list (pred bt) ...)
hidden
'ctor
arg ...)))))
(define-syntax _s_t_memo
(syntax-rules ()
((_s_t_memo 0 sel v a ...)
(sel (v 'VALUE) a ...))
((_s_t_memo lv sel v a ...)
(_complete
(make-residual-generator-vve* '_S_T_MEMO (pred lv) 'sel v a ...)))))
(define-syntax _make-cell_memo
(syntax-rules ()
((_make-cell_memo 0 lab bt arg)
(static-cell lab arg bt))
((_make-cell_memo lv lab bt arg)
(_complete
(make-residual-generator-vvve* '_MAKE-CELL_MEMO (pred lv) 'lab (pred bt) arg)))))
(define-syntax _cell-eq?_memo
(syntax-rules ()
((_cell-eq?_memo 0 ref1 ref2)
(eq? (ref1 'VALUE) (ref2 'VALUE)))
((_cell-eq?_memo lv ref1 ref2)
(_complete
(make-residual-generator-ve* '_CELL-EQ?_MEMO (pred lv) ref1 ref2)))))
(define-syntax _make-vector_memo
(syntax-rules ()
((_make-vector_memo 0 lab bt size arg)
(static-vector lab size arg bt))
((_make-vector_memo lv lab bt size arg)
(_complete
(make-residual-generator-vvve* '_MAKE-VECTOR_MEMO (pred lv) 'lab (pred bt) size arg)))))
(define-syntax _message!_memo
(syntax-rules ()
((_message!_memo 0 obj msg arg ...)
((obj 'msg) arg ...))
((_message!_memo lv obj msg arg ...)
(_complete
(make-residual-generator-veve* '_MESSAGE!_MEMO (pred lv) obj 'msg arg ...)))))
(define-syntax _if
(syntax-rules ()
((_if 0 e1 e2 e3)
(if e1 e2 e3))
; ((_if 1 e1 e2 e3)
; (shift k
; (let* ((r1 e1)
; (p2 (make-placeholder))
; (p3 (make-placeholder))
; (t2 (spawn
; (preserving-gensym-local
; (lambda ()
; (placeholder-set! p2
; (with-fresh-meta-continuation
; (lambda ()
; (reset (k e2)))))))))
; (t3 (spawn
; (preserving-gensym-local
; (lambda ()
; (placeholder-set! p3
; (with-fresh-meta-continuation
; (lambda ()
; (reset (k e3))))))))))
; (make-residual-if r1 (placeholder-value p2) (placeholder-value p3)))))
((_if 1 e1 e2 e3)
(shift k (make-residual-if e1 (reset (k e2)) (reset (k e3)))))
((_if 1 e1 e2 e3)
(shift k (let* ((cond-code e1)
(the-store (current-static-store!))
(then-code (reset (k e2)))
(xxxxxxxxx (install-static-store! the-store))
(else-code (reset (k e3))))
(make-residual-if cond-code then-code else-code))))
((_if lv e1 e2 e3)
(shift k (let* ((cond-code e1)
(the-store (current-static-store!))
(then-code (reset (k e2)))
(xxxxxxxxx (install-static-store! the-store))
(else-code (reset (k e3))))
(make-residual-generator-ve*
'_IF (pred lv) cond-code then-code else-code))))))
(define-syntax _op
(syntax-rules (apply cons _define_data _define)
((_op lv _define_data arg)
(make-residual-define-data lv arg))
((_op lv _define var arg)
(make-residual-define-mutable lv 'var arg))
((_op 0 op arg ...)
(op arg ...))
((_op 1 cons e1 e2)
(_complete (make-residual-cons e1 e2)))
((_op 1 apply f arg)
(_complete-serious-apply f arg))
((_op 1 op arg ...)
(_complete (make-residual-primop 'op arg ...)))
((_op lv op arg ...)
(_complete (make-residual-generator-vve* '_OP (pred lv) 'op arg ...)))))
(define-syntax _op-no-result
(syntax-rules (apply cons _define_data _define)
((_op-no-result lv _define_data arg)
(make-residual-define-data lv arg))
((_op-no-result lv _define var arg)
(make-residual-define-mutable lv 'var arg))
((_op-no-result 0 op arg ...)
(op arg ...))
((_op-no-result 1 cons e1 e2)
(_complete-no-result (make-residual-cons e1 e2)))
((_op-no-result 1 apply f arg)
(_complete-serious-apply-no-result f arg))
((_op-no-result 1 op arg ...)
(_complete-no-result (make-residual-primop 'op arg ...)))
((_op-no-result lv op arg ...)
(_complete-no-result
(make-residual-generator-vve* '_OP (pred lv) 'op arg ...)))))
(define-syntax _op-serious
(syntax-rules (apply cons _define_data _define)
((_op-serious lv _define_data arg)
(make-residual-define-data lv arg))
((_op-serious lv _define var arg)
(make-residual-define-mutable lv 'var arg))
((_op-serious 0 op arg ...)
(op arg ...))
((_op-serious 1 cons e1 e2)
(_complete-serious 'cons (list e1 e2)))
((_op-serious 1 apply f arg)
(_complete-serious-apply f arg))
((_op-serious 1 op arg ...)
(_complete-serious 'op (list arg ...)))
((_op-serious lv op arg ...)
(_complete (make-residual-generator-vve* '_OP-SERIOUS (pred lv) 'op arg ...)))))
(define-syntax _op-serious-no-result
(syntax-rules (apply cons _define_data _define)
((_op-serious-no-result lv _define_data arg)
(make-residual-define-data lv arg))
((_op-serious-no-result lv _define var arg)
(make-residual-define-mutable lv 'var arg))
((_op-serious-no-result 0 op arg ...)
(op arg ...))
((_op-serious-no-result 1 cons e1 e2)
(_complete-serious-no-result 'cons (list e1 e2)))
((_op-serious-no-result 1 apply f arg)
(_complete-serious-apply-no-result f arg))
((_op-serious-no-result 1 op arg ...)
(_complete-serious-no-result 'op (list arg ...)))
((_op-serious-no-result lv op arg ...)
(_complete-no-result
(make-residual-generator-vve* '_OP-SERIOUS (pred lv) 'op arg ...)))))
(define-syntax _op_pure
(syntax-rules (cons)
((_op_pure 0 op arg ...)
(op arg ...))
((_op_pure 1 cons e1 e2)
(make-residual-cons e1 e2))
((_op_pure 1 op arg ...)
(make-residual-primop 'op arg ...))
((_op_pure lv op arg ...)
(_complete
(make-residual-generator-vve* '_OP_PURE (pred lv) 'op arg ...)))))
(define-syntax _freevar
(syntax-rules ()
((_freevar 0 arg)
arg)
;;; ((_freevar 1 arg)
;;; 'arg)
((_freevar lv arg)
(make-residual-generator-vve* '_FREEVAR (pred lv) 'arg))))
(define-syntax _lift0
(syntax-rules ()
((_lift0 1 val)
(make-residual-literal val))
((_lift0 lv val)
(make-residual-generator-ve* '_LIFT0 (pred lv) val))))
(define-syntax _lift
(syntax-rules ()
((_lift 0 diff value)
(_lift0 diff value))
((_lift 1 diff value)
(make-residual-generator-ve* '_LIFT0 'diff value))
((_lift lv diff value)
(make-residual-generator-vve* '_LIFT (pred lv) 'diff value))))
(define-syntax _eval
(syntax-rules ()
((_eval 0 0 body)
(eval body (interaction-environment)))
((_eval 0 1 body)
(_complete-maybe body))
((_eval 0 diff body)
(_complete (make-residual-generator-vve* '_EVAL 0 (pred diff) body)))
((_eval 1 0 body)
(_complete
(make-residual-call 'EVAL body (make-residual-call 'INTERACTION-ENVIRONMENT))))
((_eval 1 1 body)
body) ;;;?????????? _complete ??????????
((_eval lv diff body)
(_complete
(make-residual-generator-vve* '_EVAL (pred lv) 'diff body)))))
(define-syntax _run
(syntax-rules ()
((_run 0 body)
(eval (reset body) (interaction-environment)))
((_run l body)
(_complete
(make-residual-generator-ve* '_RUN (pred l) (reset body))))))