From 8f1ebec1846e70765a7fe491e24a9a42c4193441 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Wed, 23 Mar 2011 18:12:18 -0400 Subject: [PATCH] trying to make conform work. --- compile.rkt | 27 ++++++++++++++++----------- tests/conform/program0.sch | 32 ++++++++++++++++---------------- 2 files changed, 32 insertions(+), 27 deletions(-) diff --git a/compile.rkt b/compile.rkt index 0d91c85..cedab8f 100644 --- a/compile.rkt +++ b/compile.rkt @@ -91,9 +91,7 @@ [(eq? linkage 'return) (make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel)) - ,(make-PopEnvironment - cenv - 0) + ,(make-PopEnvironment cenv 0) ,(make-PopControlFrame) ,(make-GotoStatement (make-Reg 'proc))))] [(eq? linkage 'next) @@ -332,7 +330,7 @@ (end-with-compiled-application-linkage compiled-linkage extended-cenv - (compile-proc-appl extended-cenv n target compiled-linkage)) + (compile-proc-appl cenv extended-cenv n target compiled-linkage)) primitive-branch (end-with-linkage @@ -351,13 +349,13 @@ -(: compile-proc-appl (Natural Natural Target Linkage -> InstructionSequence)) +(: compile-proc-appl (Natural Natural Natural Target Linkage -> InstructionSequence)) ;; Three fundamental cases for general compiled-procedure application. ;; 1. Non-tail calls that write to val ;; 2. Calls in argument position that write to the environment ;; 3. Tail calls. ;; The Other cases should be excluded. -(define (compile-proc-appl cenv n target linkage) +(define (compile-proc-appl cenv-without-args cenv-with-args n target linkage) (cond [(and (eq? target 'val) (not (eq? linkage 'return))) ;; This case happens for a function call that isn't in @@ -388,16 +386,23 @@ (make-instruction-sequence `(,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)) - ,(make-PopEnvironment (ensure-natural (- cenv n)) + ,(make-PopEnvironment (ensure-natural (- cenv-with-args n)) n) ,(make-GotoStatement (make-Reg 'val))))] [(and (not (eq? target 'val)) (eq? linkage 'return)) - ;; This case should be impossible: return linkage should only - ;; occur when we're in tail position, and we're in tail position - ;; only when the target is the val register. - (error 'compile "return linkage, target not val: ~s" target)])) + ;; This case happens for set!, which may install the results of an + ;; application directly into the environment. + (let ([proc-return (make-label 'procReturn)]) + (end-with-linkage linkage + cenv-without-args + (make-instruction-sequence + `(,(make-PushControlFrame proc-return) + ,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)) + ,(make-GotoStatement (make-Reg 'val)) + ,proc-return + ,(make-AssignImmediateStatement target (make-Reg 'val))))))])) (: compile-let1 (Let1 Natural Target Linkage -> InstructionSequence)) diff --git a/tests/conform/program0.sch b/tests/conform/program0.sch index aed3119..5d42a64 100644 --- a/tests/conform/program0.sch +++ b/tests/conform/program0.sch @@ -285,11 +285,11 @@ (define res (lambda (pair) (cdr pair))) (define conforms? (lambda (t1 t2) - (letrec ((nodes-with-red-edges-out (box '())) + (letrec ((nodes-with-red-edges-out '()) (add-red-edge! (lambda (from-node to-node) (set-red-edges! from-node (adjoin to-node (red-edges from-node))) - (set-box! nodes-with-red-edges-out (adjoin from-node (unbox nodes-with-red-edges-out))))) + (set! nodes-with-red-edges-out (adjoin from-node nodes-with-red-edges-out)))) (greenify-red-edges! (lambda (from-node) (set-green-edges! from-node (append (red-edges from-node) (green-edges from-node))) @@ -323,7 +323,7 @@ loop) (blue-edges t2)))))))))) (let ((result (does-conform t1 t2))) - (for-each (if result greenify-red-edges! delete-red-edges!) (unbox nodes-with-red-edges-out)) + (for-each (if result greenify-red-edges! delete-red-edges!) nodes-with-red-edges-out) result)))) (define equivalent? (lambda (a b) (if (conforms? a b) (conforms? b a) '#f))) (define classify @@ -457,23 +457,23 @@ (loop new-g new-count))))))))) (let ((graph (make-graph (adjoin any-node (adjoin none-node (graph-nodes (clean-graph g))))))) (loop graph (length (graph-nodes graph))))))) -(define a (box '())) -(define b (box '())) -(define c (box '())) -(define d (box '())) +(define a '()) +(define b '()) +(define c '()) +(define d '()) (define reset (lambda () - (set-box! a (make-node 'a '())) - (set-box! b (make-node 'b '())) - (set-blue-edges! (unbox a) (list (make-blue-edge 'phi any-node (unbox b)))) - (set-blue-edges! (unbox b) (list (make-blue-edge 'phi any-node (unbox a)) (make-blue-edge 'theta any-node (unbox b)))) - (set-box! c (make-node '"c" '())) - (set-box! d (make-node '"d" '())) - (set-blue-edges! (unbox c) (list (make-blue-edge 'theta any-node (unbox b)))) - (set-blue-edges! (unbox d) (list (make-blue-edge 'phi any-node (unbox c)) (make-blue-edge 'theta any-node (unbox d)))) + (set! a (make-node 'a '())) + (set! b (make-node 'b '())) + (set-blue-edges! a (list (make-blue-edge 'phi any-node b))) + (set-blue-edges! b (list (make-blue-edge 'phi any-node a) (make-blue-edge 'theta any-node b))) + (set! c (make-node '"c" '())) + (set! d (make-node '"d" '())) + (set-blue-edges! c (list (make-blue-edge 'theta any-node b))) + (set-blue-edges! d (list (make-blue-edge 'phi any-node c) (make-blue-edge 'theta any-node d))) '(made a b c d))) (define test - (lambda () (reset) (map name (graph-nodes (make-lattice (make-graph (list (unbox a) (unbox b) (unbox c) (unbox d) any-node none-node)) '#t))))) + (lambda () (reset) (map name (graph-nodes (make-lattice (make-graph (list a b c d any-node none-node)) '#t))))) (define go (lambda () (reset)