[Guile-commits] 02/03: Lower box, box-ref, box-set! primcalls

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 24f998e4d23f70cbe2398007eb0afbbd685aa1eb
Author: Andy Wingo <address@hidden>
Date:   Wed Jan 10 07:43:00 2018 +0100

    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 |  2 -
 module/language/cps/cse.scm              |  3 --
 module/language/cps/dce.scm              |  3 +-
 module/language/cps/effects-analysis.scm |  6 ---
 module/language/cps/types.scm            | 22 -----------
 module/language/tree-il/compile-cps.scm  | 63 ++++++++++++++++++++++++++++++++
 6 files changed, 64 insertions(+), 35 deletions(-)

diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index 12ef69b..ce40973 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/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))))
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 17a6489..a7de7a6 100644
--- a/module/language/cps/cse.scm
+++ b/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))
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 2a054d7..40f501a 100644
--- a/module/language/cps/dce.scm
+++ b/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)
diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index f2335b4..c638de6 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/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)
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index eab830a..fc649b0 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -808,28 +808,6 @@ minimum, and maximum."
 
 
 ;;;
-;;; 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))
-
-
-
-
-;;;
 ;;; Structs.
 ;;;
 
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index a4f79b9..60a4072 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/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)