[Guile-commits] 10/25: CPS pass now expects exploded vector primitives

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 6e100c9ba67bc6c30426dd08a14fb89c7a4b1a54
Author: Andy Wingo <address@hidden>
Date:   Sun Jan 7 16:14:09 2018 +0100

    CPS pass now expects exploded vector primitives
    
    * module/language/cps/closure-conversion.scm (convert-one): Reify
      make-vector inline, without field initialization.
    * 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/reify-primitives.scm (reify-primitives):
    * module/language/cps/slot-allocation.scm (compute-var-representations):
    * module/language/cps/specialize-primcalls.scm (specialize-primcalls):
    * module/language/cps/types.scm:
    * module/language/cps/compile-bytecode.scm (compile-function): Remove
      cases for make-vector, vector-ref, etc.
    * module/system/vm/assembler.scm: Remove make-vector, vector-ref etc
      exports.
---
 module/language/cps/closure-conversion.scm   | 19 ++++++++---
 module/language/cps/compile-bytecode.scm     | 18 ----------
 module/language/cps/cse.scm                  |  4 ---
 module/language/cps/dce.scm                  |  3 +-
 module/language/cps/effects-analysis.scm     | 11 ------
 module/language/cps/reify-primitives.scm     |  3 --
 module/language/cps/slot-allocation.scm      |  2 +-
 module/language/cps/specialize-primcalls.scm |  3 --
 module/language/cps/types.scm                | 50 ----------------------------
 module/system/vm/assembler.scm               |  9 +----
 10 files changed, 18 insertions(+), 104 deletions(-)

diff --git a/module/language/cps/closure-conversion.scm 
b/module/language/cps/closure-conversion.scm
index 2e5a910..550e1f9 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -35,6 +35,7 @@
                                         filter-map
                                         ))
   #:use-module (srfi srfi-11)
+  #:use-module (system base types internal)
   #:use-module (language cps)
   #:use-module (language cps utils)
   #:use-module (language cps with-cps)
@@ -536,10 +537,20 @@ term."
          (unless (> nfree 2)
            (error "unexpected well-known nullary, unary, or binary closure"))
          (with-cps cps
-           ($ (with-cps-constants ((false #f))
-                (build-term
-                  ($continue k src
-                    ($primcall 'make-vector/immediate nfree (false))))))))))
+           (letv v w0)
+           (letk k* ($kargs () () ($continue k src ($values (v)))))
+           (letk ktag1
+                 ($kargs ('w0) (w0)
+                   ($continue k* src
+                     ($primcall 'word-set!/immediate '(vector . 0) (v w0)))))
+           (letk ktag0
+                 ($kargs ('v) (v)
+                   ($continue ktag1 src
+                     ($primcall 'load-u64 (+ %tc7-vector (ash nfree 8)) ()))))
+           (build-term
+             ($continue ktag0 src
+               ($primcall 'allocate-words/immediate `(vector . ,(1+ nfree))
+                          ())))))))
 
     (define (init-closure cps k src var known? free)
       "Initialize the free variables @var{closure-free} in a closure
diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index 79459cf..ec93eaa 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -175,18 +175,6 @@
                                     idx))
         (($ $primcall 'free-ref idx (closure))
          (emit-free-ref asm (from-sp dst) (from-sp (slot closure)) idx))
-        (($ $primcall 'vector-ref #f (vector index))
-         (emit-vector-ref asm (from-sp dst) (from-sp (slot vector))
-                          (from-sp (slot index))))
-        (($ $primcall 'make-vector #f (length init))
-         (emit-make-vector asm (from-sp dst) (from-sp (slot length))
-                           (from-sp (slot init))))
-        (($ $primcall 'make-vector/immediate length (init))
-         (emit-make-vector/immediate asm
-                                     (from-sp dst) length (from-sp (slot 
init))))
-        (($ $primcall 'vector-ref/immediate index (vector))
-         (emit-vector-ref/immediate asm
-                                    (from-sp dst) (from-sp (slot vector)) 
index))
         (($ $primcall 'allocate-struct #f (vtable nfields))
          (emit-allocate-struct asm (from-sp dst) (from-sp (slot vtable))
                                (from-sp (slot nfields))))
@@ -336,12 +324,6 @@
         (($ $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))))
-        (($ $primcall 'vector-set!/immediate index (vector value))
-         (emit-vector-set!/immediate asm (from-sp (slot vector))
-                                     index (from-sp (slot value))))
         (($ $primcall 'string-set! #f (string index char))
          (emit-string-set! asm (from-sp (slot string)) (from-sp (slot index))
                            (from-sp (slot char))))
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 2b1a229..f3c333c 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -263,10 +263,6 @@ false.  It could be that both true and false proofs are 
available."
 
            ((set-car! #f o x)                (x <- car #f o))
            ((set-cdr! #f o y)                (y <- cdr #f o))
-           ;; FIXME: how to propagate make-vector/immediate -> vector-length?
-           ((v <- make-vector #f n x)        (n <- vector-length #f v))
-           ((vector-set! #f v i x)           (x <- vector-ref #f v i))
-           ((vector-set!/immediate i v x)    (x <- vector-ref/immediate i v))
            ((s <- allocate-struct #f v n)    (v <- struct-vtable #f s))
            ((s <- allocate-struct/immediate n v) (v <- struct-vtable #f s))
            ((struct-set! #f s i x)           (x <- struct-ref #f s i))
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 0de6101..0a3a311 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 'vector-set! 'vector-set!/immediate
-                          'set-car! 'set-cdr!
+                      (or 'set-car! 'set-cdr!
                           'box-set!
                           'scm-set! 'scm-set!/tag 'scm-set!/immediate
                           'word-set! 'word-set!/immediate) _
diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index 473b280..87c2540 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -402,17 +402,6 @@ the LABELS that are clobbered by the effects of LABEL."
   ((box-ref v)                     (&read-object &box)         &type-check)
   ((box-set! v x)                  (&write-object &box)        &type-check))
 
-;; Vectors.
-(define-primitive-effects* param
-  ((vector . _)                    (&allocate &vector))
-  ((make-vector n init)            (&allocate &vector))
-  ((make-vector/immediate init)    (&allocate &vector))
-  ((vector-ref v n)                (&read-object &vector)      &type-check)
-  ((vector-ref/immediate v)        (&read-field &vector param) &type-check)
-  ((vector-set! v n x)             (&write-object &vector)     &type-check)
-  ((vector-set!/immediate v x)     (&write-field &vector param) &type-check)
-  ((vector-length v)                                           &type-check))
-
 ;; Structs.
 (define-primitive-effects* param
   ((allocate-struct vt n)          (&allocate &struct)         &type-check)
diff --git a/module/language/cps/reify-primitives.scm 
b/module/language/cps/reify-primitives.scm
index 2dc8136..4580f83 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -310,9 +310,6 @@
             ((sub/immediate (u8? y) x) (sub x y))
             (_
              (reify-u64-constants
-              ((make-vector/immediate (u8? size) init) (make-vector size init))
-              ((vector-ref/immediate (u8? idx) v) (vector-ref v idx))
-              ((vector-set!/immediate (u8? idx) v val) (vector-set! v idx val))
               ((allocate-struct/immediate (u8? size) vt) (allocate-struct vt 
size))
               ((struct-ref/immediate (u8? idx) s) (struct-ref s idx))
               ((struct-set!/immediate (u8? idx) s val) (struct-set! s idx val))
diff --git a/module/language/cps/slot-allocation.scm 
b/module/language/cps/slot-allocation.scm
index 48d9877..3f73a20 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -752,7 +752,7 @@ are comparable with eqv?.  A tmp slot may be used."
               (intmap-add representations var 'f64))
              (($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64
                                'char->integer 's64->u64
-                               'bv-length 'vector-length 'string-length
+                               'bv-length 'string-length
                                'uadd 'usub 'umul
                                'ulogand 'ulogior 'ulogxor 'ulogsub 'ursh 'ulsh
                                'uadd/immediate 'usub/immediate 'umul/immediate
diff --git a/module/language/cps/specialize-primcalls.scm 
b/module/language/cps/specialize-primcalls.scm
index b791a20..5d57805 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -121,9 +121,6 @@
           ...
           (_ #f)))
       (specialize-case
-        (('make-vector (? uint? n) init) (make-vector/immediate n (init)))
-        (('vector-ref v (? uint? n)) (vector-ref/immediate n (v)))
-        (('vector-set! v (? uint? n) x) (vector-set!/immediate n (v x)))
         (('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)))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 0c9ce84..230c1eb 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -834,56 +834,6 @@ minimum, and maximum."
 
 
 ;;;
-;;; Vectors.
-;;;
-
-(define-syntax-rule (&max/vector x)
-  (min (&max x) (target-max-vector-length)))
-
-(define-simple-type-checker (make-vector (&u64 0 (target-max-vector-length))
-                                         &all-types))
-(define-type-inferrer (make-vector size init result)
-  (restrict! size &u64 0 (target-max-vector-length))
-  (define! result &vector (&min/0 size) (&max/vector size)))
-
-(define-type-checker (vector-ref v idx)
-  (and (check-type v &vector 0 (target-max-vector-length))
-       (check-type idx &u64 0 (1- (&min v)))))
-(define-type-inferrer (vector-ref v idx result)
-  (restrict! v &vector (1+ (&min/0 idx)) (target-max-vector-length))
-  (restrict! idx &u64 0 (1- (&max/vector v)))
-  (define! result &all-types -inf.0 +inf.0))
-
-(define-type-checker (vector-set! v idx val)
-  (and (check-type v &vector 0 (target-max-vector-length))
-       (check-type idx &u64 0 (1- (&min v)))))
-(define-type-inferrer (vector-set! v idx val)
-  (restrict! v &vector (1+ (&min/0 idx)) (target-max-vector-length))
-  (restrict! idx &u64 0 (1- (&max/vector v))))
-
-(define-type-inferrer/param (make-vector/immediate size init result)
-  (define! result &vector size size))
-
-(define-type-checker/param (vector-ref/immediate idx v)
-  (and (check-type v &vector 0 (target-max-vector-length)) (< idx (&min v))))
-(define-type-inferrer/param (vector-ref/immediate idx v result)
-  (restrict! v &vector (1+ idx) (target-max-vector-length))
-  (define! result &all-types -inf.0 +inf.0))
-
-(define-type-checker/param (vector-set!/immediate idx v val)
-  (and (check-type v &vector 0 (target-max-vector-length)) (< idx (&min v))))
-(define-type-inferrer/param (vector-set!/immediate idx v val)
-  (restrict! v &vector (1+ idx) (target-max-vector-length)))
-
-(define-simple-type-checker (vector-length &vector))
-(define-type-inferrer (vector-length v result)
-  (restrict! v &vector 0 (target-max-vector-length))
-  (define! result &u64 (&min/0 v) (&max/vector v)))
-
-
-
-
-;;;
 ;;; Structs.
 ;;;
 
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 7af7050..489bfd5 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1,6 +1,6 @@
 ;;; Guile bytecode assembler
 
-;;; Copyright (C) 2001, 2009, 2010, 2012, 2013, 2014, 2015, 2017 Free Software 
Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010, 2012, 2013, 2014, 2015, 2017, 2018 Free 
Software Foundation, Inc.
 ;;;
 ;;; This library is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -243,13 +243,6 @@
             emit-ulsh/immediate
             emit-char->integer
             emit-integer->char
-            emit-make-vector
-            emit-make-vector/immediate
-            emit-vector-length
-            emit-vector-ref
-            emit-vector-ref/immediate
-            emit-vector-set!
-            emit-vector-set!/immediate
             emit-struct-vtable
             emit-allocate-struct/immediate
             emit-struct-ref/immediate