[Guile-commits] 19/25: Expand pair-related primcalls

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 49fa4980bb58d8421acc0711d7acc8eaaf088050
Author: Andy Wingo <address@hidden>
Date:   Sun Jan 7 18:19:29 2018 +0100

    Expand pair-related primcalls
    
    * module/language/tree-il/compile-cps.scm (ensure-pair): New helper.
      (cons, car, cdr, set-car!, set-cdr!): New expanders.
    * module/language/cps/closure-conversion.scm (convert-one):
    * module/language/cps/contification.scm (apply-contification): Emit
      lower-level instructions for making pairs.
---
 module/language/cps/closure-conversion.scm |  6 +--
 module/language/cps/contification.scm      | 17 +++++--
 module/language/tree-il/compile-cps.scm    | 76 ++++++++++++++++++++++++++++++
 3 files changed, 93 insertions(+), 6 deletions(-)

diff --git a/module/language/cps/closure-conversion.scm 
b/module/language/cps/closure-conversion.scm
index 550e1f9..4f92963 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -528,9 +528,9 @@ term."
          ;; Well-known closure with two free variables; the closure is a
          ;; pair.
          (with-cps cps
-           ($ (with-cps-constants ((false #f))
-                (build-term
-                  ($continue k src ($primcall 'cons #f (false false))))))))
+           (build-term
+             ($continue k src
+               ($primcall 'allocate-words/immediate `(pair . 2) ())))))
         ;; Well-known callee with more than two free variables; the closure
         ;; is a vector.
         (#(#t nfree)
diff --git a/module/language/cps/contification.scm 
b/module/language/cps/contification.scm
index 5c96bb3..934ae5e 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -382,9 +382,20 @@ function set."
            (build-term ($continue k src ($const '())))))
         ((v . vals)
          (with-cps cps
-           (letv tail)
-           (letk ktail ($kargs ('tail) (tail)
-                         ($continue k src ($primcall 'cons #f (v tail)))))
+           (letv pair tail)
+           (letk kdone ($kargs () () ($continue k src ($values (pair)))))
+           (letk ktail
+                 ($kargs () ()
+                   ($continue kdone src
+                     ($primcall 'scm-set!/immediate '(pair . 1) (pair tail)))))
+           (letk khead
+                 ($kargs ('pair) (pair)
+                   ($continue ktail src
+                     ($primcall 'scm-set!/immediate '(pair . 0) (pair v)))))
+           (letk ktail
+                 ($kargs ('tail) (tail)
+                   ($continue khead src
+                     ($primcall 'allocate-words/immediate '(pair . 2) ()))))
            ($ (build-list ktail src vals))))))
     (cond
      ((and (not rest) (eqv? (length vals) nreq))
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 29bcf46..40f0047 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -425,6 +425,82 @@
         ($continue ktag0 src
           ($primcall 'allocate-words/immediate `(vector . ,nwords) ()))))))
 
+(define (ensure-pair cps src op pred x is-pair)
+  (define msg
+    (match pred
+      ('pair?
+       "Wrong type argument in position 1 (expecting pair): ~S")
+      ('mutable-pair?
+       "Wrong type argument in position 1 (expecting mutable pair): ~S")))
+  (define not-pair (vector 'wrong-type-arg (symbol->string op) msg))
+  (with-cps cps
+    (letk knot-pair ($kargs () () ($throw src 'throw/value+data not-pair (x))))
+    (let$ body (is-pair))
+    (letk k ($kargs () () ,body))
+    (letk kheap-object ($kargs () () ($branch knot-pair k src pred #f (x))))
+    (build-term ($branch knot-pair kheap-object src 'heap-object? #f (x)))))
+
+(define-primcall-converter cons
+  (lambda (cps k src op param head tail)
+    (with-cps cps
+      (letv pair)
+      (letk kdone
+            ($kargs () ()
+              ($continue k src ($values (pair)))))
+      (letk ktail
+            ($kargs () ()
+              ($continue kdone src
+                ($primcall 'scm-set!/immediate '(pair . 1) (pair tail)))))
+      (letk khead
+            ($kargs ('pair) (pair)
+              ($continue ktail src
+                ($primcall 'scm-set!/immediate '(pair . 0) (pair head)))))
+      (build-term
+        ($continue khead src
+          ($primcall 'allocate-words/immediate '(pair . 2) ()))))))
+
+(define-primcall-converter car
+  (lambda (cps k src op param pair)
+    (ensure-pair
+     cps src 'car 'pair? pair
+     (lambda (cps)
+       (with-cps cps
+         (build-term
+           ($continue k src
+             ($primcall 'scm-ref/immediate '(pair . 0) (pair)))))))))
+
+(define-primcall-converter cdr
+  (lambda (cps k src op param pair)
+    (ensure-pair
+     cps src 'cdr 'pair? pair
+     (lambda (cps)
+       (with-cps cps
+         (build-term
+           ($continue k src
+             ($primcall 'scm-ref/immediate '(pair . 1) (pair)))))))))
+
+(define-primcall-converter set-car!
+  (lambda (cps k src op param pair val)
+    (ensure-pair
+     ;; FIXME: Use mutable-pair? as predicate.
+     cps src 'set-car! 'pair? pair
+     (lambda (cps)
+       (with-cps cps
+         (build-term
+           ($continue k src
+             ($primcall 'scm-set!/immediate '(pair . 0) (pair val)))))))))
+
+(define-primcall-converter set-cdr!
+  (lambda (cps k src op param pair val)
+    (ensure-pair
+     ;; FIXME: Use mutable-pair? as predicate.
+     cps src 'set-cdr! 'pair? pair
+     (lambda (cps)
+       (with-cps cps
+         (build-term
+           ($continue k src
+             ($primcall 'scm-set!/immediate '(pair . 1) (pair val)))))))))
+
 (define-primcall-converters
   (char->integer scm >u64)
   (integer->char u64 >scm)