summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/cps/reify-primitives.scm3
-rw-r--r--module/language/tree-il/compile-cps.scm59
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