From d18813441649665f42b524443c65d0b6bb4ac59a Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@google.com>
Date: Tue, 12 Jul 2022 22:55:48 -0700
Subject: Add builtin operations to IR1.

---
 csc/cps-test.csc | 33 +++++++++++++++++++++++++++++++++
 csc/cps.csc      | 42 ++++++++++++++++++++++++++++--------------
 csc/ir1.csc      | 19 +++++++++++++++++++
 3 files changed, 80 insertions(+), 14 deletions(-)

diff --git a/csc/cps-test.csc b/csc/cps-test.csc
index 9881a2d..4259586 100644
--- a/csc/cps-test.csc
+++ b/csc/cps-test.csc
@@ -10,6 +10,7 @@
           lexical-ref?
           library-ref?
           make-call
+          make-call-builtin
           make-constant
           make-define-syntax
           make-if
@@ -141,6 +142,38 @@
     transform-ir2))
 
 
+(test call-builtin-alloc
+  (assert-equal
+    (make-primitive 'alloc (list (make-constant 10)) (list (test-ref 'generated-symbol))
+      (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))
+    (ir1->ir2 (make-call-builtin 'alloc (list (make-constant 10))) tail)
+    transform-ir2))
+
+
+(test call-builtin-peek
+  (assert-equal
+    (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'generated-symbol))
+      (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol))
+        (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol)))))
+    (ir1->ir2
+      (make-call-builtin 'peek (list (make-call-builtin 'alloc (list (make-constant 1))) (make-constant 0)))
+      tail)
+    transform-ir2))
+
+
+(test call-builtin-poke
+  (assert-equal
+    (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'generated-symbol))
+      (make-primitive 'poke (list (make-constant 10) (test-ref 'generated-symbol) (make-constant 0)) '()
+        (make-apply (test-ref 'tail) (list (make-constant #f)))))
+    (ir1->ir2
+      (make-call-builtin 'poke (list (make-constant 10)
+                                     (make-call-builtin 'alloc (list (make-constant 1)))
+                                     (make-constant 0)))
+      tail)
+    transform-ir2))
+
+
 (test sequence
   (assert-equal
     (make-primitive 'poke (list (make-constant 5) (test-ref 'a) (make-constant 0)) '()
diff --git a/csc/cps.csc b/csc/cps.csc
index a5b7d3b..d8cd8bd 100644
--- a/csc/cps.csc
+++ b/csc/cps.csc
@@ -15,6 +15,7 @@
             merge)
           (only (csc ir1)
             %call
+            %call-builtin
             %define-syntax
             %if
             %lambda
@@ -161,20 +162,33 @@
               (lambda (f)
                 ; Technically the order of evaluation is unspecified.
                 ; We evaluate expressions left to right.
-                ;
-                ; I would use the loop macro, but it mutates the loop
-                ; variables which plays badly with building a lambda.
-                (let loop ((args* (reverse args))
-                           (exprs (lambda (vals)
-                                    (make-apply f (cons return-address (reverse vals))))))
-                  (if (null? args*)
-                    (exprs '())
-                    (loop (cdr args*)
-                          (lambda (vals)
-                            (to-cps
-                              (car args*)
-                              (lambda (val)
-                                (exprs (cons val vals))))))))))))
+                (loop for arg in (reverse args)
+                      with expr = (lambda (vals)
+                                    (make-apply f (cons return-address (reverse vals))))
+                      do (set! expr (let ((e* expr)
+                                          (arg* arg)) ; make copies to avoid modifying the expr in the closure.
+                                      (lambda (vals)
+                                        (to-cps arg*
+                                          (lambda (val)
+                                            (e* (cons val vals)))))))
+                      finally (return (expr '())))))))
+        ((% %call-builtin op args)
+          (define returns-value? (not (symbol=? op 'poke)))
+          (loop for arg in (reverse args)
+                with expr = (lambda (vals)
+                              (if returns-value?
+                                (let ((result (new-ref)))
+                                  (make-primitive op (reverse vals) (list result)
+                                    (continuation result)))
+                                (make-primitive op (reverse vals) '()
+                                  (continuation (make-constant #f)))))
+                do (set! expr (let ((e* expr)
+                                    (arg* arg))
+                                (lambda (vals)
+                                  (to-cps arg*
+                                    (lambda (val)
+                                      (e* (cons val vals)))))))
+                finally (return (expr '()))))
         ((% %sequence head tail)
           (to-cps
             head
diff --git a/csc/ir1.csc b/csc/ir1.csc
index 942f8f9..484b38f 100644
--- a/csc/ir1.csc
+++ b/csc/ir1.csc
@@ -1,6 +1,7 @@
 (define-library (csc ir1)
   (export
     %call
+    %call-builtin
     %constant
     %define-syntax
     %if
@@ -12,6 +13,9 @@
     %library-ref
     %sequence
     call-arguments
+    call-builtin-arguments
+    call-builtin-operation
+    call-builtin?
     call-procedure
     call?
     constant-expression
@@ -46,6 +50,7 @@
     library-ref-name
     library-ref?
     make-call
+    make-call-builtin
     make-constant
     make-define-syntax
     make-if
@@ -157,6 +162,20 @@
       (arguments call-arguments))
 
 
+    ; <call-builtin> operation arguments
+    ; Executes the given builtin operation on the arguments. The known builtin
+    ; operations are listed below. Each operation can return a value, or not.
+    ;   - alloc: size -> result
+    ;   - peek: pointer * offset -> result
+    ;   - poke: word * pointer * offset -> ()
+    (define-match-record-type <call-builtin>
+      (make-call-builtin operation arguments)
+      call-builtin?
+      %call-builtin
+      (operation call-builtin-operation)
+      (arguments call-builtin-arguments))
+
+
     ; <sequence> head tail
     ; Evaluate head, ignoring any result. Then tail is evaluated.
     (define-match-record-type <sequence>
-- 
cgit v1.3.1