[Guile-commits] 04/10: Add primitive support for working with module variables

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 35d19661e3390e10c674c1e9f23465dd8506837d
Author: Andy Wingo <address@hidden>
Date:   Fri Aug 16 14:18:30 2019 +0200

    Add primitive support for working with module variables
    
    * module/language/tree-il/compile-cps.scm (%box-ref, %box-set!): New
      expanders.
      (box-ref, box-set!): Expand in terms of %box-ref, %box-set!.
    * module/language/tree-il/cps-primitives.scm (%variable-ref):
    (%variable-set!, module-ensure-local-variable!): New primitives.
    * module/language/tree-il/effects.scm (make-effects-analyzer):
      Understand effects of new primitives.
    * module/language/tree-il/primitives.scm (define!):
    (module-define!): Define expanders.
---
 module/language/tree-il/compile-cps.scm    | 40 ++++++++++++++++++------------
 module/language/tree-il/cps-primitives.scm |  4 ++-
 module/language/tree-il/effects.scm        |  9 +++++++
 module/language/tree-il/primitives.scm     |  6 +++++
 4 files changed, 42 insertions(+), 17 deletions(-)

diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index d97ead9..8f048a5 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -507,6 +507,28 @@
         ($continue ktag0 src
           ($primcall 'allocate-words/immediate '(box . 2) ()))))))
 
+(define-primcall-converter %box-ref
+  (lambda (cps k src op param box)
+    (define unbound
+      #(misc-error "variable-ref" "Unbound variable: ~S"))
+    (with-cps cps
+      (letv val)
+      (letk kunbound ($kargs () () ($throw src 'throw/value unbound (box))))
+      (letk kbound ($kargs () () ($continue k src ($values (val)))))
+      (letk ktest
+            ($kargs ('val) (val)
+              ($branch kbound kunbound src 'undefined? #f (val))))
+      (build-term
+        ($continue ktest src
+          ($primcall 'scm-ref/immediate '(box . 1) (box)))))))
+
+(define-primcall-converter %box-set!
+  (lambda (cps k src op param box val)
+    (with-cps cps
+      (build-term
+        ($continue k src
+          ($primcall 'scm-set!/immediate '(box . 1) (box val)))))))
+
 (define (ensure-box cps src op x is-box)
   (define not-box
     (vector 'wrong-type-arg
@@ -521,31 +543,17 @@
 
 (define-primcall-converter box-ref
   (lambda (cps k src op param box)
-    (define unbound
-      #(misc-error "variable-ref" "Unbound variable: ~S"))
     (ensure-box
      cps src 'variable-ref box
      (lambda (cps)
-       (with-cps cps
-         (letv val)
-         (letk kunbound ($kargs () () ($throw src 'throw/value unbound (box))))
-         (letk kbound ($kargs () () ($continue k src ($values (val)))))
-         (letk ktest
-               ($kargs ('val) (val)
-                 ($branch kbound kunbound src 'undefined? #f (val))))
-         (build-term
-           ($continue ktest src
-             ($primcall 'scm-ref/immediate '(box . 1) (box)))))))))
+       (convert-primcall cps k src '%box-ref param box)))))
 
 (define-primcall-converter box-set!
   (lambda (cps k src op param box val)
     (ensure-box
      cps src 'variable-set! box
      (lambda (cps)
-       (with-cps cps
-         (build-term
-           ($continue k src
-             ($primcall 'scm-set!/immediate '(box . 1) (box val)))))))))
+       (convert-primcall cps k src '%box-set! param box val)))))
 
 (define (ensure-struct cps src op x have-vtable)
   (define not-struct
diff --git a/module/language/tree-il/cps-primitives.scm 
b/module/language/tree-il/cps-primitives.scm
index 17afa0d..beb29b9 100644
--- a/module/language/tree-il/cps-primitives.scm
+++ b/module/language/tree-il/cps-primitives.scm
@@ -48,9 +48,11 @@
 (define-cps-primitive box 1 1)
 (define-cps-primitive (variable-ref box-ref) 1 1)
 (define-cps-primitive (variable-set! box-set!) 2 0)
+(define-cps-primitive (%variable-ref %box-ref) 1 1)
+(define-cps-primitive (%variable-set! %box-set!) 2 0)
 
 (define-cps-primitive current-module 0 1)
-(define-cps-primitive define! 1 1)
+(define-cps-primitive (module-ensure-local-variable! define!) 2 1)
 
 (define-cps-primitive wind 2 0)
 (define-cps-primitive unwind 0 0)
diff --git a/module/language/tree-il/effects.scm 
b/module/language/tree-il/effects.scm
index 05016a3..6e5ff33 100644
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -416,6 +416,15 @@ of an expression."
                    (cause &type-check)
                    (cause &variable)))
 
+          (($ <primcall> _ '%variable-ref (v))
+           (logior (compute-effects v)
+                   (cause &type-check) ;; For the unbound check.
+                   &variable))
+          (($ <primcall> _ '%variable-set! (v x))
+           (logior (compute-effects v)
+                   (compute-effects x)
+                   (cause &variable)))
+
           (($ <primcall> _ 'struct-ref (s n))
            (logior (compute-effects s)
                    (compute-effects n)
diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index a2ea9ad..b7bd4fb 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -398,6 +398,12 @@
                            (make-primcall src 'list (cons message args))
                            (make-const src #f)))))))
 
+(define-primitive-expander define! (sym val)
+  (%variable-set! (module-ensure-local-variable! (current-module) sym) val))
+
+(define-primitive-expander module-define! (mod sym val)
+  (%variable-set! (module-ensure-local-variable! mod sym) val))
+
 (define-primitive-expander zero? (x)
   (= x 0))