guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 15/16: Use intrinsics for top-level refs outside capture


From: Andy Wingo
Subject: [Guile-commits] 15/16: Use intrinsics for top-level refs outside captured scopes
Date: Mon, 14 May 2018 10:48:36 -0400 (EDT)

wingo pushed a commit to branch master
in repository guile.

commit 76eac85084a2d0bab33500f17f5a92a580e43551
Author: Andy Wingo <address@hidden>
Date:   Mon May 14 15:46:52 2018 +0200

    Use intrinsics for top-level refs outside captured scopes
    
    * module/language/tree-il/compile-cps.scm (toplevel-box): Reify
      intrinsic calls for top-level references outside captured scopes.
    * module/language/cps/reify-primitives.scm (compute-known-primitives):
      Update set of macro-instructions.
---
 module/language/cps/reify-primitives.scm |  3 +-
 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 551e1b4..e3dfee8 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 23eb5ea..7672524 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



reply via email to

[Prev in Thread] Current Thread [Next in Thread]