[Guile-commits] 22/25: Better compilation of vector constructors and initializers

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 5e1109a97feb94425a23a3a567afcd217da4ffab
Author: Andy Wingo <address@hidden>
Date:   Sun Jan 7 22:20:55 2018 +0100

    Better compilation of vector constructors and initializers
    
    * module/language/tree-il/cps-primitives.scm (allocate-vector)
      (vector-init!): Declare these primitives which later go away when
      lowering to CPS.
    * module/language/tree-il/compile-cps.scm (vector-init!): New
      converter.
      (allocate-vector): New converter.
---
 module/language/tree-il/compile-cps.scm    | 41 +++++++++++++++++++++++++++---
 module/language/tree-il/cps-primitives.scm |  2 ++
 2 files changed, 40 insertions(+), 3 deletions(-)

diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 40f0047..6a9784a 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -337,6 +337,37 @@
            ($continue k src
              ($primcall 'scm-set!/immediate `(vector . ,pos) (v val)))))))))
 
+(define-primcall-converter vector-init!
+  (lambda (cps k src op param v val)
+    (define pos (1+ param))
+    (with-cps cps
+      (build-term
+        ($continue k src
+          ($primcall 'scm-set!/immediate `(vector . ,pos) (v val)))))))
+
+(define-primcall-converter allocate-vector
+  (lambda (cps k src op param)
+    (define size param)
+    (define nwords (1+ size))
+    (unless (and (exact-integer? size) (<= 0 size (target-max-vector-length)))
+      (error "precondition failed" size))
+    (with-cps cps
+      (letv v w0)
+      (letk kdone
+            ($kargs () ()
+              ($continue k src ($values (v)))))
+      (letk ktag1
+            ($kargs ('w0) (w0)
+              ($continue kdone src
+                ($primcall 'word-set!/immediate '(vector . 0) (v w0)))))
+      (letk ktag0
+            ($kargs ('v) (v)
+              ($continue ktag1 src
+                ($primcall 'load-u64 (+ %tc7-vector (ash size 8)) ()))))
+      (build-term
+        ($continue ktag0 src
+          ($primcall 'allocate-words/immediate `(vector . ,nwords) ()))))))
+
 (define-primcall-converter make-vector
   (lambda (cps k src op param size init)
     (untag-fixnum-in-imm-range
@@ -1124,12 +1155,16 @@
            (define (negint? val) (and (exact-integer? val) (< val 0)))
            ;; FIXME: Add case for mul
            (specialize-case
+            (('allocate-vector ($ <const> _ n))
+             (allocate-vector n ()))
             (('make-vector ($ <const> _ (? vector-size? n)) init)
              (make-vector/immediate n (init)))
             (('vector-ref v ($ <const> _ (? vector-index? n)))
              (vector-ref/immediate n (v)))
             (('vector-set! v ($ <const> _ (? vector-index? n)) x)
              (vector-set!/immediate n (v x)))
+            (('vector-init! v ($ <const> _ n) x)
+             (vector-init! n (v x)))
             (('allocate-struct v ($ <const> _ (? uint? n)))
              (allocate-struct/immediate n (v)))
             (('struct-ref s ($ <const> _ (? uint? n)))
@@ -1589,7 +1624,7 @@ integer."
                                 (primcall equal? a b))))))))
 
        (($ <primcall> src 'vector args)
-        ;; Expand to "make-vector" + "vector-set!".
+        ;; Expand to "allocate-vector" + "vector-init!".
         (evaluate-args-eagerly-if-needed
          src args
          (lambda (args)
@@ -1597,12 +1632,12 @@ integer."
              (make-primcall src 'name (list . args)))
            (define-syntax-rule (const val)
              (make-const src val))
-           (let ((v (primcall make-vector (const (length args)) (const #f))))
+           (let ((v (primcall allocate-vector (const (length args)))))
              (with-lexicals src (v)
                (list->seq
                 src
                 (append (map (lambda (idx arg)
-                               (primcall vector-set! v (const idx) arg))
+                               (primcall vector-init! v (const idx) arg))
                              (iota (length args))
                              args)
                         (list v))))))))
diff --git a/module/language/tree-il/cps-primitives.scm 
b/module/language/tree-il/cps-primitives.scm
index d3b261e..6888ab9 100644
--- a/module/language/tree-il/cps-primitives.scm
+++ b/module/language/tree-il/cps-primitives.scm
@@ -94,10 +94,12 @@
 (define-cps-primitive logsub 2 1)
 (define-cps-primitive logbit? 2 1)
 
+(define-cps-primitive allocate-vector 1 1)
 (define-cps-primitive make-vector 2 1)
 (define-cps-primitive vector-length 1 1)
 (define-cps-primitive vector-ref 2 1)
 (define-cps-primitive vector-set! 3 0)
+(define-cps-primitive vector-init! 3 0)
 
 (define-cps-primitive struct-vtable 1 1)
 (define-cps-primitive allocate-struct 2 1)