[Guile-commits] 06/16: Immediate parameter for struct-ref et al

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit d7ecf35d70a75807e993dc998aa225f512b2116a
Author: Andy Wingo <address@hidden>
Date:   Wed Nov 1 15:23:24 2017 +0100

    Immediate parameter for struct-ref et al
    
    * module/language/cps/compile-bytecode.scm (compile-function):
    * module/language/cps/cse.scm (compute-equivalent-subexpressions):
    * module/language/cps/effects-analysis.scm:
    * module/language/cps/slot-allocation.scm (compute-needs-slot):
    * module/language/cps/specialize-primcalls.scm (specialize-primcalls):
    * module/language/cps/types.scm (allocate-struct/immediate)
      (struct-ref/immediate, struct-set!/immediate): Immediate struct
      constructor and accessor use immediate primcall parameters.
---
 module/language/cps/compile-bytecode.scm     | 14 +++++++-------
 module/language/cps/cse.scm                  | 13 +++++++++----
 module/language/cps/effects-analysis.scm     | 18 ++++++------------
 module/language/cps/slot-allocation.scm      |  6 ------
 module/language/cps/specialize-primcalls.scm | 12 +++++++++---
 module/language/cps/types.scm                | 23 ++++++++++++++++++-----
 6 files changed, 49 insertions(+), 37 deletions(-)

diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index 23ee43b..a259a25 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -168,16 +168,16 @@
         (($ $primcall 'allocate-struct #f (vtable nfields))
          (emit-allocate-struct asm (from-sp dst) (from-sp (slot vtable))
                                (from-sp (slot nfields))))
-        (($ $primcall 'allocate-struct/immediate #f (vtable nfields))
+        (($ $primcall 'allocate-struct/immediate nfields (vtable))
          (emit-allocate-struct/immediate asm (from-sp dst)
                                          (from-sp (slot vtable))
-                                         (constant nfields)))
+                                         nfields))
         (($ $primcall 'struct-ref #f (struct n))
          (emit-struct-ref asm (from-sp dst) (from-sp (slot struct))
                           (from-sp (slot n))))
-        (($ $primcall 'struct-ref/immediate #f (struct n))
+        (($ $primcall 'struct-ref/immediate idx (struct))
          (emit-struct-ref/immediate asm (from-sp dst) (from-sp (slot struct))
-                                    (constant n)))
+                                    idx))
         (($ $primcall 'char->integer #f (src))
          (emit-char->integer asm (from-sp dst) (from-sp (slot src))))
         (($ $primcall 'integer->char #f (src))
@@ -309,9 +309,9 @@
         (($ $primcall 'struct-set! #f (struct index value))
          (emit-struct-set! asm (from-sp (slot struct)) (from-sp (slot index))
                            (from-sp (slot value))))
-        (($ $primcall 'struct-set!/immediate #f (struct index value))
-         (emit-struct-set!/immediate asm (from-sp (slot struct))
-                                     (constant index) (from-sp (slot value))))
+        (($ $primcall 'struct-set!/immediate idx (struct value))
+         (emit-struct-set!/immediate asm (from-sp (slot struct)) idx
+                                     (from-sp (slot value))))
         (($ $primcall 'vector-set! #f (vector index value))
          (emit-vector-set! asm (from-sp (slot vector)) (from-sp (slot index))
                            (from-sp (slot value))))
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 5dba8fc..a074c7b 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -289,16 +289,21 @@ false.  It could be that both true and false proofs are 
available."
              (add-def! `(primcall vector-ref #f ,vec ,idx) val))
             (('primcall 'vector-set!/immediate idx vec val)
              (add-def! `(primcall vector-ref/immediate ,idx ,vec) val))
-            (('primcall (or 'allocate-struct 'allocate-struct/immediate) #f
-                        vtable size)
+            (('primcall 'allocate-struct #f vtable size)
              (match defs
                ((struct)
                 (add-def! `(primcall struct-vtable #f ,(subst struct))
                           vtable))))
+            (('primcall 'allocate-struct/immediate size vtable)
+             (match defs
+               ((struct)
+                (add-def! `(primcall struct-vtable #f ,(subst struct))
+                          vtable))))
+            ;; FIXME: Aren't we missing some "subst" calls here?
             (('primcall 'struct-set! #f struct n val)
              (add-def! `(primcall struct-ref #f ,struct ,n) val))
-            (('primcall 'struct-set!/immediate #f struct n val)
-             (add-def! `(primcall struct-ref/immediate #f ,struct ,n) val))
+            (('primcall 'struct-set!/immediate n struct val)
+             (add-def! `(primcall struct-ref/immediate ,n ,struct) val))
             (('primcall 'scm->f64 #f scm)
              (match defs
                ((f64)
diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index 44814e6..e3dacaf 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -342,20 +342,14 @@ is or might be a read or a write to the same location as 
A."
   ((vector-length v)                                           &type-check))
 
 ;; Structs.
-(define (struct-field n constants)
-  (indexed-field &struct n constants))
-(define (read-struct-field n constants)
-  (logior &read (struct-field n constants)))
-(define (write-struct-field n constants)
-  (logior &write (struct-field n constants)))
-(define-primitive-effects* constants
+(define-primitive-effects* param
   ((allocate-struct vt n)          (&allocate &struct)         &type-check)
-  ((allocate-struct/immediate v n) (&allocate &struct)         &type-check)
+  ((allocate-struct/immediate vt)  (&allocate &struct)         &type-check)
   ((make-struct/no-tail vt . _)    (&allocate &struct)         &type-check)
-  ((struct-ref s n)                (read-struct-field n constants) &type-check)
-  ((struct-ref/immediate s n)      (read-struct-field n constants) &type-check)
-  ((struct-set! s n x)             (write-struct-field n constants) 
&type-check)
-  ((struct-set!/immediate s n x)   (write-struct-field n constants) 
&type-check)
+  ((struct-ref s n)                (&read-object &vector)      &type-check)
+  ((struct-ref/immediate s)        (&read-field &struct param) &type-check)
+  ((struct-set! s n x)             (&write-object &struct)     &type-check)
+  ((struct-set!/immediate s x)     (&write-field &struct param) &type-check)
   ((struct-vtable s)                                           &type-check))
 
 ;; Strings.
diff --git a/module/language/cps/slot-allocation.scm 
b/module/language/cps/slot-allocation.scm
index 38dbbda..b37b43e 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -335,12 +335,6 @@ the definitions that are live before and after LABEL, as 
intsets."
               empty-intset)
              ;; FIXME: Move all of these instructions to use $primcall
              ;; params.
-             (($ $primcall 'allocate-struct/immediate #f (vtable nfields))
-              (defs+ vtable))
-             (($ $primcall 'struct-ref/immediate #f (s n))
-              (defs+ s))
-             (($ $primcall 'struct-set!/immediate #f (s n x))
-              (defs+* (intset s x)))
              (($ $primcall (or 'add/immediate 'sub/immediate
                                'uadd/immediate 'usub/immediate 'umul/immediate
                                'ursh/immediate 'ulsh/immediate) #f
diff --git a/module/language/cps/specialize-primcalls.scm 
b/module/language/cps/specialize-primcalls.scm
index 61a2bc9..9d4545f 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -62,9 +62,15 @@
         (('vector-set! v (? u8? n) x)
          (build-exp
            ($primcall 'vector-set!/immediate (intmap-ref constants n) (v x))))
-        (('allocate-struct v (? u8? n)) (rename 'allocate-struct/immediate))
-        (('struct-ref s (? u8? n)) (rename 'struct-ref/immediate))
-        (('struct-set! s (? u8? n) x) (rename 'struct-set!/immediate))
+        (('allocate-struct v (? u8? n))
+         (build-exp
+           ($primcall 'allocate-struct/immediate (intmap-ref constants n) 
(v))))
+        (('struct-ref s (? u8? n))
+         (build-exp
+           ($primcall 'struct-ref/immediate (intmap-ref constants n) (s))))
+        (('struct-set! s (? u8? n) x)
+         (build-exp
+           ($primcall 'struct-set!/immediate (intmap-ref constants n) (s x))))
         (('add x (? u8? y)) (build-exp ($primcall 'add/immediate #f (x y))))
         (('add (? u8? x) y) (build-exp ($primcall 'add/immediate #f (y x))))
         (('sub x (? u8? y)) (build-exp ($primcall 'sub/immediate #f (x y))))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 31d8b28..606d6d0 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -784,7 +784,7 @@ minimum, and maximum."
 (define-type-checker (struct-ref s idx)
   (and (check-type s &struct 0 *max-size-t*)
        (check-type idx &u64 0 *max-size-t*)
-       ;; FIXME: is the field readable?
+       ;; FIXME: is the field boxed?
        (< (&max idx) (&min s))))
 (define-type-inferrer (struct-ref s idx result)
   (restrict! s &struct (1+ (&min/0 idx)) *max-size-t*)
@@ -794,15 +794,28 @@ minimum, and maximum."
 (define-type-checker (struct-set! s idx val)
   (and (check-type s &struct 0 *max-size-t*)
        (check-type idx &u64 0 *max-size-t*)
-       ;; FIXME: is the field writable?
+       ;; FIXME: is the field boxed?
        (< (&max idx) (&min s))))
 (define-type-inferrer (struct-set! s idx val)
   (restrict! s &struct (1+ (&min/0 idx)) *max-size-t*)
   (restrict! idx &u64 0 (1- (&max/size s))))
 
-(define-type-aliases allocate-struct allocate-struct/immediate)
-(define-type-aliases struct-ref struct-ref/immediate)
-(define-type-aliases struct-set! struct-set!/immediate)
+(define-type-inferrer/param (allocate-struct/immediate size vt result)
+  (restrict! vt &struct vtable-offset-user *max-size-t*)
+  (define! result &struct size size))
+
+(define-type-checker/param (struct-ref/immediate idx s)
+  ;; FIXME: is the field boxed?
+  (and (check-type s &struct 0 *max-size-t*) (< idx (&min s))))
+(define-type-inferrer/param (struct-ref/immediate idx s result)
+  (restrict! s &struct (1+ idx) *max-size-t*)
+  (define! result &all-types -inf.0 +inf.0))
+
+(define-type-checker/param (struct-set!/immediate idx s val)
+  ;; FIXME: is the field boxed?
+  (and (check-type s &struct 0 *max-size-t*) (< idx (&min s))))
+(define-type-inferrer/param (struct-set!/immediate idx s val)
+  (restrict! s &struct (1+ idx) *max-size-t*))
 
 (define-simple-type (struct-vtable (&struct 0 *max-size-t*))
   (&struct vtable-offset-user *max-size-t*))