diff options
-rw-r--r-- | module/language/cps/reify-primitives.scm | 3 | ||||
-rw-r--r-- | module/language/tree-il/compile-cps.scm | 59 |
2 files changed, 44 insertions, 18 deletions
diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index 551e1b4c5..e3dfee87f 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -330,7 +330,8 @@ push-fluid pop-fluid fluid-ref fluid-set! push-dynamic-state pop-dynamic-state lsh rsh lsh/immediate rsh/immediate - cache-ref cache-set!)) + cache-ref cache-set! + resolve-module lookup define!)) (let ((table (make-hash-table))) (for-each (match-lambda ((inst . _) (hashq-set! table inst #t))) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 23eb5eaa5..7672524c1 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -1394,23 +1394,48 @@ (scope-counter (1+ scope-id)) scope-id)) -(define (toplevel-box cps src name bound? val-proc) - (define (lookup cps k) - (match (current-topbox-scope) - (#f - (with-cps cps - ;; FIXME: Resolve should take name as immediate. - ($ (with-cps-constants ((name name)) - ($ (convert-primcall k src 'resolve (list bound?) name)))))) - (scope - (with-cps cps - ($ (convert-primcall k src 'cached-toplevel-box - (list scope name bound?))))))) - (with-cps cps - (letv box) - (let$ body (val-proc box)) - (letk kbox ($kargs ('box) (box) ,body)) - ($ (lookup kbox)))) +(define (toplevel-box cps src name bound? have-var) + (define %unbound + #(unbound-variable #f "Unbound variable: ~S")) + (match (current-topbox-scope) + (#f + (with-cps cps + (letv mod name-var box) + (letk kbad ($kargs () () ($throw src 'throw/value %unbound (name-var)))) + (let$ body + ((if bound? + (lambda (cps) + (with-cps cps + (letv val) + (let$ body (have-var box)) + (letk kdef ($kargs () () ,body)) + (letk ktest ($kargs ('val) (val) + ($branch kdef kbad src + 'undefined? #f (val)))) + (build-term + ($continue ktest src + ($primcall 'scm-ref/immediate + '(box . 1) (box)))))) + (lambda (cps) + (with-cps cps + ($ (have-var box))))))) + (letk ktest ($kargs () () ,body)) + (letk kbox ($kargs ('box) (box) + ($branch kbad ktest src 'heap-object? #f (box)))) + (letk kname ($kargs ('name) (name-var) + ($continue kbox src + ($primcall 'lookup #f (mod name-var))))) + (letk kmod ($kargs ('mod) (mod) + ($continue kname src ($const name)))) + (build-term + ($continue kmod src ($primcall 'current-module #f ()))))) + (scope + (with-cps cps + (letv box) + (let$ body (have-var box)) + (letk kbox ($kargs ('box) (box) ,body)) + ($ (convert-primcall kbox src 'cached-toplevel-box + (list scope name bound?))))))) (define (module-box cps src module name public? bound? val-proc) (with-cps cps |