[Guile-commits] 05/08: Assignment conversion uses unchecked memory accessors

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit eed4e097235d563f8e3355b33af6d39c995228b0
Author: Andy Wingo <address@hidden>
Date:   Wed Dec 6 11:26:03 2017 +0100

    Assignment conversion uses unchecked memory accessors
    
    * module/language/cps/effects-analysis.scm (annotation->memory-kind):
      Add box type annotation.
    * module/language/cps/reify-primitives.scm (primitive-ref): Reify
      scm-ref/immediate instead of box-ref.
    * module/language/cps/specialize-primcalls.scm (specialize-primcalls):
      Remove needless and unbound -> literal.
    * module/language/cps/types.scm (annotation->type): Add box type.
    * module/language/tree-il/compile-cps.scm (convert): Reify
      scm-ref/immediate / scm-set!/immediate instead of box-ref / box-set!.
---
 module/language/cps/effects-analysis.scm     |  3 ++-
 module/language/cps/reify-primitives.scm     |  5 +++--
 module/language/cps/specialize-primcalls.scm | 16 ++++++++--------
 module/language/cps/types.scm                |  3 ++-
 module/language/tree-il/compile-cps.scm      | 25 +++++++++++++++++--------
 5 files changed, 32 insertions(+), 20 deletions(-)

diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index a2157ec..4105bfa 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -341,7 +341,8 @@ the LABELS that are clobbered by the effects of LABEL."
   ;; FIXME: Flesh this out.
   (match annotation
     ('pair &pair)
-    ('vector &vector)))
+    ('vector &vector)
+    ('box &box)))
 
 (define-primitive-effects* param
   ((allocate-words size)           (&allocate (annotation->memory-kind param)))
diff --git a/module/language/cps/reify-primitives.scm 
b/module/language/cps/reify-primitives.scm
index dea81b6..1610356 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -91,7 +91,8 @@
               (lambda (cps box)
                 (with-cps cps
                   (build-term
-                    ($continue k src ($primcall 'box-ref #f (box))))))))
+                    ($continue k src
+                      ($primcall 'scm-ref/immediate '(box . 1) (box))))))))
 
 (define (builtin-ref cps idx k src)
   (with-cps cps
@@ -257,7 +258,7 @@
                            (letv n*)
                            (letk kop ($kargs ('n) (n*)
                                        ($continue k src
-                                         ($primcall 'allocate-words ann (n)))))
+                                         ($primcall 'allocate-words ann 
(n*)))))
                            (setk label ($kargs names vars
                                          ($continue kop src
                                            ($primcall 'load-u64 n ())))))))))
diff --git a/module/language/cps/specialize-primcalls.scm 
b/module/language/cps/specialize-primcalls.scm
index a5f1aee..9767ee4 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -108,10 +108,10 @@
       (define (rename name)
         (build-exp ($primcall name param args)))
       (define-syntax compute-constant
-        (syntax-rules (->)
-          ((_ (c -> exp) body)
+        (syntax-rules ()
+          ((_ (c exp) body)
            (let* ((c (intmap-ref constants c)) (c exp)) body))
-          ((_ c body) (compute-constant (c -> c) body))))
+          ((_ c body) (compute-constant (c c) body))))
       (define-syntax-rule (specialize-case (pat (op c (arg ...))) ...)
         (match (cons name args)
           (pat
@@ -125,11 +125,11 @@
         (('allocate-struct v (? uint? n)) (allocate-struct/immediate n (v)))
         (('struct-ref s (? uint? n)) (struct-ref/immediate n (s)))
         (('struct-set! s (? uint? n) x) (struct-set!/immediate n (s x)))
-        (('allocate-words (? uint? n)) (allocate-words/immediate (n -> (cons 
param n)) ()))
-        (('scm-ref o (? uint? i)) (scm-ref/immediate (i -> (cons param i)) 
(o)))
-        (('scm-set! o (? uint? i) x) (scm-set!/immediate (i -> (cons param i)) 
(o x)))
-        (('word-ref o (? uint? i)) (word-ref/immediate (i -> (cons param i)) 
(o)))
-        (('word-set! o (? uint? i) x) (word-set!/immediate (i -> (cons param 
i)) (o x)))
+        (('allocate-words (? uint? n)) (allocate-words/immediate (n (cons 
param n)) ()))
+        (('scm-ref o (? uint? i)) (scm-ref/immediate (i (cons param i)) (o)))
+        (('scm-set! o (? uint? i) x) (scm-set!/immediate (i (cons param i)) (o 
x)))
+        (('word-ref o (? uint? i)) (word-ref/immediate (i (cons param i)) (o)))
+        (('word-set! o (? uint? i) x) (word-set!/immediate (i (cons param i)) 
(o x)))
         (('add x (? num? y)) (add/immediate y (x)))
         (('add (? num? y) x) (add/immediate y (x)))
         (('sub x (? num? y)) (sub/immediate y (x)))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index efe86be..62c9d50 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -712,7 +712,8 @@ minimum, and maximum."
 (define (annotation->type ann)
   ;; Expand me!
   (match ann
-    ('vector &vector)))
+    ('vector &vector)
+    ('box &box)))
 
 (define-type-inferrer/param (allocate-words param size result)
   (define! result (annotation->type param) (&min/0 size) (&max/scm-size size)))
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 786b965..624cbd6 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -360,7 +360,8 @@
             (letv unboxed)
             (let$ body (k unboxed))
             (letk kunboxed ($kargs ('unboxed) (unboxed) ,body))
-            (build-term ($continue kunboxed src ($primcall 'box-ref #f 
(box))))))
+            (build-term ($continue kunboxed src
+                          ($primcall 'scm-ref/immediate '(box . 1) (box))))))
          ((orig-var subst-var #f) (k cps subst-var))
          (var (k cps var))))
       ((? single-valued?)
@@ -411,7 +412,8 @@
      (with-cps cps
        (let$ k (adapt-arity k src 1))
        (rewrite-term (hashq-ref subst sym)
-         ((orig-var box #t) ($continue k src ($primcall 'box-ref #f (box))))
+         ((orig-var box #t) ($continue k src
+                              ($primcall 'scm-ref/immediate '(box . 1) (box))))
          ((orig-var subst-var #f) ($continue k src ($values (subst-var))))
          (var ($continue k src ($values (var)))))))
 
@@ -491,7 +493,8 @@
       (lambda (cps box)
         (with-cps cps
           (let$ k (adapt-arity k src 1))
-          (build-term ($continue k src ($primcall 'box-ref #f (box))))))))
+          (build-term ($continue k src
+                        ($primcall 'scm-ref/immediate '(box . 1) (box))))))))
 
     (($ <module-set> src mod name public? exp)
      (convert-arg cps exp
@@ -502,7 +505,8 @@
             (with-cps cps
               (let$ k (adapt-arity k src 0))
               (build-term
-                ($continue k src ($primcall 'box-set! #f (box val))))))))))
+                ($continue k src
+                  ($primcall 'scm-set!/immediate '(box . 1) (box val))))))))))
 
     (($ <toplevel-ref> src name)
      (toplevel-box
@@ -510,7 +514,9 @@
       (lambda (cps box)
         (with-cps cps
           (let$ k (adapt-arity k src 1))
-          (build-term ($continue k src ($primcall 'box-ref #f (box))))))))
+          (build-term
+            ($continue k src
+              ($primcall 'scm-ref/immediate '(box . 1) (box))))))))
 
     (($ <toplevel-set> src name exp)
      (convert-arg cps exp
@@ -521,7 +527,8 @@
             (with-cps cps
               (let$ k (adapt-arity k src 0))
               (build-term
-                ($continue k src ($primcall 'box-set! #f (box val))))))))))
+                ($continue k src
+                  ($primcall 'scm-set!/immediate '(box . 1) (box val))))))))))
 
     (($ <toplevel-define> src name exp)
      (convert-arg cps exp
@@ -530,7 +537,8 @@
            (let$ k (adapt-arity k src 0))
            (letv box)
            (letk kset ($kargs ('box) (box)
-                        ($continue k src ($primcall 'box-set! #f (box val)))))
+                        ($continue k src
+                          ($primcall 'scm-set!/immediate '(box . 1) (box 
val)))))
            ($ (with-cps-constants ((name name))
                 (build-term
                   ($continue kset src ($primcall 'define! #f (name))))))))))
@@ -921,7 +929,8 @@
             (with-cps cps
               (let$ k (adapt-arity k src 0))
               (build-term
-                ($continue k src ($primcall 'box-set! #f (box exp))))))))))
+                ($continue k src
+                  ($primcall 'scm-set!/immediate '(box . 1) (box exp))))))))))
 
     (($ <seq> src head tail)
      (if (zero-valued? head)