Lower box, box-ref, box-set! primcalls

* module/language/tree-il/compile-cps.scm (box, ensure-box):
  (box-ref, box-set!): Lower box primcalls.
* module/language/cps/compile-bytecode.scm (compile-function):
* module/language/cps/cse.scm (compute-equivalent-subexpressions):
* module/language/cps/dce.scm (compute-live-code):
* module/language/cps/effects-analysis.scm:
* module/language/cps/types.scm: Remove special support for boxes.  What
  a pleasure!

module/language/cps/compile-bytecode.scm

@@ -316,8 +316,6 @@
         (($ $primcall 'free-set! idx (closure value))
          (emit-free-set! asm (from-sp (slot closure)) (from-sp (slot value))
                          idx))
-        (($ $primcall 'box-set! #f (box value))
-         (emit-box-set! asm (from-sp (slot box)) (from-sp (slot value))))
         (($ $primcall 'struct-set! #f (struct index value))
          (emit-struct-set! asm (from-sp (slot struct)) (from-sp (slot index))
                            (from-sp (slot value))))

module/language/cps/cse.scm

@@ -251,9 +251,6 @@ false.  It could be that both true and false proofs are available."
                   (add-def! (list 'op* arg* ...) aux) ...)
                  (_ (add-definitions . clauses))))))
           (add-definitions
-           ((b <- box #f o)                  (o <- box-ref #f b))
-           ((box-set! #f b o)                (o <- box-ref #f b))
-
            ((scm-set! p s i x)               (x <- scm-ref p s i))
            ((scm-set!/tag p s x)             (x <- scm-ref/tag p s))
            ((scm-set!/immediate p s x)       (x <- scm-ref/immediate p s))

module/language/cps/dce.scm

@@ -188,8 +188,7 @@ sites."
            (and (causes-effect? fx &write)
                 (match exp
                   (($ $primcall
-                      (or 'box-set!
-                          'scm-set! 'scm-set!/tag 'scm-set!/immediate
+                      (or 'scm-set! 'scm-set!/tag 'scm-set!/immediate
                           'word-set! 'word-set!/immediate) _
                       (obj . _))
                    (or (var-live? obj live-vars)

module/language/cps/effects-analysis.scm

@@ -381,12 +381,6 @@ the LABELS that are clobbered by the effects of LABEL."
                                       (&write-field
                                        (annotation->memory-kind ann) idx)))))
 
-;; Variables.
-(define-primitive-effects
-  ((box v)                         (&allocate &box))
-  ((box-ref v)                     (&read-object &box)         &type-check)
-  ((box-set! v x)                  (&write-object &box)        &type-check))
-
 ;; Structs.
 (define-primitive-effects* param
   ((allocate-struct vt n)          (&allocate &struct)         &type-check)

module/language/cps/types.scm

@@ -805,28 +805,6 @@ minimum, and maximum."
   ((current-thread) &all-types))
 
 
-
-
-;;;
-;;; Prompts.  (Nothing to do.)
-;;;
-
-
-
-
-;;;
-;;; Variables.
-;;;
-
-(define-simple-types
-  ((box &all-types) (&box 1))
-  ((box-ref (&box 1)) &all-types))
-
-(define-simple-type-checker (box-set! (&box 0 1) &all-types))
-(define-type-inferrer (box-set! box val)
-  (restrict! box &box 1 1))
-
-
 
 
 ;;;

module/language/tree-il/compile-cps.scm

@@ -553,6 +553,69 @@
            ($continue k src
              ($primcall 'scm-set!/immediate '(pair . 1) (pair val)))))))))
 
+(define-primcall-converter box
+  (lambda (cps k src op param val)
+    (with-cps cps
+      (letv obj tag)
+      (letk kdone
+            ($kargs () ()
+              ($continue k src ($values (obj)))))
+      (letk kval
+            ($kargs () ()
+              ($continue kdone src
+                ($primcall 'scm-set!/immediate '(box . 1) (obj val)))))
+      (letk ktag1
+            ($kargs ('tag) (tag)
+              ($continue kval src
+                ($primcall 'word-set!/immediate '(box . 0) (obj tag)))))
+      (letk ktag0
+            ($kargs ('obj) (obj)
+              ($continue ktag1 src
+                ($primcall 'load-u64 %tc7-variable ()))))
+      (build-term
+        ($continue ktag0 src
+          ($primcall 'allocate-words/immediate '(box . 2) ()))))))
+
+(define (ensure-box cps src op x is-box)
+  (define not-box
+    (vector 'wrong-type-arg
+            (symbol->string op)
+            "Wrong type argument in position 1 (expecting box): ~S"))
+  (with-cps cps
+    (letk knot-box ($kargs () () ($throw src 'throw/value+data not-box (x))))
+    (let$ body (is-box))
+    (letk k ($kargs () () ,body))
+    (letk kheap-object ($kargs () () ($branch knot-box k src 'variable? #f (x))))
+    (build-term ($branch knot-box kheap-object src 'heap-object? #f (x)))))
+
+(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)))))))))
+
+(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)))))))))
+
 (define-primcall-converters
   (char->integer scm >u64)
   (integer->char u64 >scm)