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

@@ -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

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)

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)

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))