suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

trying to make conform work.

Browse Source
This commit is contained in:
Danny Yoo 2011-03-23 18:12:18 -04:00
parent b433c6e6c7
commit 8f1ebec184
2 changed files with 32 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
compile.rkt
View File

@ -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))

32
tests/conform/program0.sch
View File

@ -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)