From 2fb60ef2d527b40c7f2e1b6408b2c357dd3b6932 Mon Sep 17 00:00:00 2001 From: Rose Hogenson Date: Fri, 29 Jul 2022 17:29:13 -0700 Subject: Fix test failures. --- csc/codegen-test.csc | 46 ++++++++-------- csc/cps-test.csc | 15 +++-- csc/cps.csc | 151 +++++++++++++++++++++++++++++---------------------- 3 files changed, 115 insertions(+), 97 deletions(-) diff --git a/csc/codegen-test.csc b/csc/codegen-test.csc index ef1c88b..29d1da5 100644 --- a/csc/codegen-test.csc +++ b/csc/codegen-test.csc @@ -36,11 +36,11 @@ (test codegen-apply (define p (test-var)) (assert-equal - '((label init) - (peek (local 1) (local 0) (const 5)) + '((peek (local 1) (local 0) (const 5)) (mov (local 2) (local 1)) (mov (local 1) (const 10)) - (jmp (local 2))) + (jmp (local 2)) + (label 0)) (ir2->ir3 (make-fix '() (make-primitive 'peek (list *globals* (make-constant 5)) (list p) @@ -50,12 +50,12 @@ (test codegen-call-global (define p (test-var)) (assert-equal - '((label init) - (peek (local 1) (local 0) (global cons (csc based))) + '((peek (local 1) (local 0) (global cons (csc based))) (mov (local 3) (local 1)) (mov (local 1) (const 5)) (mov (local 2) (const ())) - (jmp (local 3))) + (jmp (local 3)) + (label 0)) (ir2->ir3 (make-fix '() (make-primitive 'peek (list *globals* (make-library-ref 'cons '(csc based))) (list p) @@ -66,12 +66,12 @@ (define f (test-label)) (define ret (test-var)) (assert-equal - '((label 0) + '((mov (local 1) (label 1)) + (jmp (label 1)) + (label 1) (mov (local 2) (local 1)) (jmp (local 2)) - (label init) - (mov (local 1) (label 0)) - (jmp (label 0))) + (label 0)) (ir2->ir3 (make-fix (list (make-closure f (list ret) @@ -88,20 +88,20 @@ (define g2 (test-var)) (define g3 (test-var)) (assert-equal - '((label 0) + '((mov (local 1) (const 0)) + (mov (local 2) (const 1)) + (jmp (label 1)) + (label 1) (mov (local 127) (local 1)) (mov (local 1) (local 2)) (mov (local 2) (local 127)) (mov (local 3) (const 0)) - (jmp (label 1)) - (label 1) + (jmp (label 2)) + (label 2) (mov (local 2) (local 1)) (mov (local 1) (local 3)) - (jmp (label 0)) - (label init) - (mov (local 1) (const 0)) - (mov (local 2) (const 1)) - (jmp (label 0))) + (jmp (label 1)) + (label 0)) (ir2->ir3 (make-fix (list (make-closure f (list f1 f2) @@ -114,16 +114,16 @@ (test codegen-branch (define p (test-var)) (assert-equal - '((label init) - (peek (local 1) (local 0) (const 1)) - (jmpif (const #t) (label 0)) + '((peek (local 1) (local 0) (const 1)) + (jmpif (const #t) (label 1)) (mov (local 2) (local 1)) (mov (local 1) (const 10)) (jmp (local 2)) - (label 0) + (label 1) (mov (local 2) (local 1)) (mov (local 1) (const 5)) - (jmp (local 2))) + (jmp (local 2)) + (label 0)) (ir2->ir3 (make-fix '() (make-primitive 'peek (list *globals* (make-constant 1)) (list p) diff --git a/csc/cps-test.csc b/csc/cps-test.csc index 6439d78..156ba60 100644 --- a/csc/cps-test.csc +++ b/csc/cps-test.csc @@ -477,14 +477,13 @@ (define ret-sym (gensym)) (define x-sym (gensym)) (assert-equal - (make-primitive 'alloc (list (make-constant 1)) (list (test-var)) - (make-fix - (list - (make-closure (make-label (gensym)) (list (test-var) (test-var) (test-var)) - (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var)) - (make-primitive 'poke (list (test-var) (test-var) (make-constant 0)) '() - (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var)) - (make-apply (test-var) (list (test-var) (make-constant #f)))))))) + (make-fix + (list (make-closure (make-label (gensym)) (list (test-var) (test-var) (test-var)) + (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var)) + (make-primitive 'poke (list (test-var) (test-var) (make-constant 0)) '() + (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var)) + (make-apply (test-var) (list (test-var) (make-constant #f)))))))) + (make-primitive 'alloc (list (make-constant 1)) (list (test-var)) (make-primitive 'alloc (list (make-constant 2)) (list (test-var)) (make-primitive 'poke (list (make-label (gensym)) (test-var) (make-constant 0)) '() (make-primitive 'poke (list (test-var) (test-var) (make-constant 1)) '() diff --git a/csc/cps.csc b/csc/cps.csc index cdd6611..0dc8a96 100644 --- a/csc/cps.csc +++ b/csc/cps.csc @@ -447,6 +447,24 @@ continuation))) + (define (hoist expr) + (define functions '()) + (define body + (let hoist ((expr expr)) + (match expr + ((% %primitive op args res cont) + (make-primitive op args res (hoist cont))) + ((% %branch atom true false) + (make-branch atom (hoist true) (hoist false))) + ((% %apply . _) expr) + ((% %tail) expr) + ((% %fix funs body) + (set! functions (append funs functions)) + (hoist body)) + (_ (error "Unexpected form in hoist" expr))))) + (make-fix functions body)) + + (define (free-vars-expr expr bound-vars) (define (free? ref) (and (lexical-ref? ref) @@ -514,70 +532,71 @@ ; converts a CPS expression into an equivalent expression with no ; free variables. (define (closure-convert expr) - (let convert ((expr expr) - (env (make-ref-map))) - (define (translate ref) - (translate-ref ref env)) - (match expr - ((% %primitive op args res continuation) - (loop for r in res - do (set! env (insert env r (make-variable (gensym))))) - (make-primitive op (map translate args) (map translate res) (convert continuation env))) - ((% %branch atom true false) - (make-branch (translate atom) (convert true env) (convert false env))) - ((% %apply proc args) - (let ((p (translate proc)) - (fn (make-variable (gensym)))) - (make-primitive 'peek (list p (make-constant 0)) (list fn) - (make-apply fn (cons p (map translate args)))))) - ((% %tail) - *tail*) - ((% %fix functions body) - (define frees (map free-vars functions)) - (define fn-ptrs (loop for fun in functions - collect (make-label (gensym)))) - (define converted-functions (loop for fun in functions - for fn-ptr in fn-ptrs - for free-list in frees - for env* = env - for name = (closure-name fun) - for closure = (make-variable (gensym)) - if (lexical-ref? name) - do (set! env* (insert env* name closure)) - do (loop for arg in (closure-arguments fun) - do (set! env* (insert env* arg (make-variable (gensym))))) - (loop for var in free-list - do (set! env* (insert env* var (make-variable (gensym))))) - collect (let ((new-body (convert (closure-body fun) env*))) - (loop for var in free-list - for i from 0 - do (set! new-body (make-primitive 'peek (list closure (make-constant i)) (list (translate-ref var env*)) - new-body))) - (make-closure - fn-ptr - (cons closure (map (lambda (x) (translate-ref x env*)) (closure-arguments fun))) - new-body)))) - (loop for fun in functions - for name = (closure-name fun) - if (lexical-ref? name) - do (set! env (insert env name (make-variable (gensym))))) - (let ((new-body (convert body env))) - ; Build the closures. - (loop for fun in functions - for free-list in frees - for ptr in fn-ptrs - for closure = (translate (closure-name fun)) - do (loop for var in free-list - for i from 1 - do (set! new-body (make-primitive 'poke (list (translate var) closure (make-constant i)) '() - new-body))) - (set! new-body (make-primitive 'poke (list ptr closure (make-constant 0)) '() - new-body))) - ; Allocate the closures. + (hoist + (let convert ((expr expr) + (env (make-ref-map))) + (define (translate ref) + (translate-ref ref env)) + (match expr + ((% %primitive op args res continuation) + (loop for r in res + do (set! env (insert env r (make-variable (gensym))))) + (make-primitive op (map translate args) (map translate res) (convert continuation env))) + ((% %branch atom true false) + (make-branch (translate atom) (convert true env) (convert false env))) + ((% %apply proc args) + (let ((p (translate proc)) + (fn (make-variable (gensym)))) + (make-primitive 'peek (list p (make-constant 0)) (list fn) + (make-apply fn (cons p (map translate args)))))) + ((% %tail) + *tail*) + ((% %fix functions body) + (define frees (map free-vars functions)) + (define fn-ptrs (loop for fun in functions + collect (make-label (gensym)))) + (define converted-functions (loop for fun in functions + for fn-ptr in fn-ptrs + for free-list in frees + for env* = env + for name = (closure-name fun) + for closure = (make-variable (gensym)) + if (lexical-ref? name) + do (set! env* (insert env* name closure)) + do (loop for arg in (closure-arguments fun) + do (set! env* (insert env* arg (make-variable (gensym))))) + (loop for var in free-list + do (set! env* (insert env* var (make-variable (gensym))))) + collect (let ((new-body (convert (closure-body fun) env*))) + (loop for var in free-list + for i from 0 + do (set! new-body (make-primitive 'peek (list closure (make-constant i)) (list (translate-ref var env*)) + new-body))) + (make-closure + fn-ptr + (cons closure (map (lambda (x) (translate-ref x env*)) (closure-arguments fun))) + new-body)))) (loop for fun in functions - for free-list in frees - for closure = (translate (closure-name fun)) - do (set! new-body (make-primitive 'alloc (list (make-constant (+ 1 (length free-list)))) (list closure) - new-body))) - (make-fix converted-functions new-body))) - (_ (error "Unexpected form in closure-convert" expr))))))) + for name = (closure-name fun) + if (lexical-ref? name) + do (set! env (insert env name (make-variable (gensym))))) + (let ((new-body (convert body env))) + ; Build the closures. + (loop for fun in functions + for free-list in frees + for ptr in fn-ptrs + for closure = (translate (closure-name fun)) + do (loop for var in free-list + for i from 1 + do (set! new-body (make-primitive 'poke (list (translate var) closure (make-constant i)) '() + new-body))) + (set! new-body (make-primitive 'poke (list ptr closure (make-constant 0)) '() + new-body))) + ; Allocate the closures. + (loop for fun in functions + for free-list in frees + for closure = (translate (closure-name fun)) + do (set! new-body (make-primitive 'alloc (list (make-constant (+ 1 (length free-list)))) (list closure) + new-body))) + (make-fix converted-functions new-body))) + (_ (error "Unexpected form in closure-convert" expr)))))))) -- cgit v1.3.1