diff options
| -rw-r--r-- | csc/cps-test.csc | 33 | ||||
| -rw-r--r-- | csc/cps.csc | 42 | ||||
| -rw-r--r-- | 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> |