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

keeping track of closure names

Browse Source
This commit is contained in:
Danny Yoo 2011-03-14 18:53:05 -04:00
parent 70d0cccce6
commit 77f90ba95c
9 changed files with 171 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
assemble.rkt
View File

@ -354,7 +354,7 @@ EOF
;; during install-closure-values.
(reverse (MakeCompiledProcedure-closed-vals op)))
", ")
(symbol->string (MakeCompiledProcedure-label op)))]
(symbol->string (MakeCompiledProcedure-display-name op)))]
[(ApplyPrimitiveProcedure? op)
(format "MACHINE.proc(~a, ~a)"

65
compile.rkt
View File

@ -16,6 +16,11 @@
call/cc-label
make-call/cc-code)
(: current-defined-name (Parameterof (U Symbol False)))
(define current-defined-name (make-parameter #f))
;(provide compile-top)
(: -compile (ExpressionCore Target Linkage -> (Listof Statement)))
@ -184,10 +189,11 @@
(error 'compile-definition "Defintion not at toplevel")]
[(PrefixAddress? lexical-pos)
(let ([get-value-code
(compile (Def-value exp) cenv (make-EnvPrefixReference
(PrefixAddress-depth lexical-pos)
(PrefixAddress-pos lexical-pos))
'next)])
(parameterize ([current-defined-name var])
(compile (Def-value exp) cenv (make-EnvPrefixReference
(PrefixAddress-depth lexical-pos)
(PrefixAddress-pos lexical-pos))
'next))])
(end-with-linkage
linkage
cenv
@ -255,7 +261,8 @@
`(,(make-AssignPrimOpStatement target
(make-MakeCompiledProcedure proc-entry
(length (Lam-parameters exp))
lexical-references)))))
lexical-references
(current-defined-name))))))
(compile-lambda-body exp cenv
lexical-references
free-vars
@ -489,10 +496,11 @@
(: compile-let1 (Let1 CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-let1 exp cenv target linkage)
(let*: ([rhs-code : InstructionSequence
(compile (Let1-rhs exp)
(extend-lexical-environment/placeholders cenv 1)
(make-EnvLexicalReference 0 #f)
'next)]
(parameterize ([current-defined-name (Let1-name exp)])
(compile (Let1-rhs exp)
(extend-lexical-environment/placeholders cenv 1)
(make-EnvLexicalReference 0 #f)
'next))]
[after-let1 : Symbol (make-label 'afterLetOne)]
[after-body-code : Symbol (make-label 'afterLetBody)]
[extended-cenv : CompileTimeEnvironment
@ -526,15 +534,16 @@
(let*: ([n : Natural (length (Let-rhss exp))]
[rhs-codes : (Listof InstructionSequence)
(map (lambda: ([rhs : ExpressionCore]
[i : Natural])
(compile rhs
(extend-lexical-environment/placeholders cenv n)
(make-EnvLexicalReference i #f)
'next))
[i : Natural]
[name : Symbol])
(parameterize ([current-defined-name name])
(compile rhs
(extend-lexical-environment/placeholders cenv n)
(make-EnvLexicalReference i #f)
'next)))
(Let-rhss exp)
(build-list n
(lambda: ([i : Natural])
i)))]
(build-list n (lambda: ([i : Natural]) i))
(Let-names exp))]
[after-let : Symbol (make-label 'afterLet)]
[after-body-code : Symbol (make-label 'afterLetBody)]
[extended-cenv : CompileTimeEnvironment
@ -566,16 +575,17 @@
(let*: ([n : Natural (length (LetRec-rhss exp))]
[rhs-codes : (Listof InstructionSequence)
(map (lambda: ([rhs : ExpressionCore]
[i : Natural])
(compile rhs
(extend-lexical-environment/boxed-names cenv
(LetRec-names exp))
(make-EnvLexicalReference i #t)
'next))
[i : Natural]
[name : Symbol])
(parameterize ([current-defined-name name])
(compile rhs
(extend-lexical-environment/boxed-names cenv
(LetRec-names exp))
(make-EnvLexicalReference i #t)
'next)))
(LetRec-rhss exp)
(build-list n
(lambda: ([i : Natural])
i)))]
(build-list n (lambda: ([i : Natural]) i))
(LetRec-names exp))]
[after-letrec : Symbol (make-label 'afterLetRec)]
[after-body-code : Symbol (make-label 'afterLetBody)]
[extended-cenv : CompileTimeEnvironment
@ -679,7 +689,8 @@
(make-MakeCompiledProcedure call/cc-closure-entry
1 ;; the continuation consumes a single value
(list (make-EnvLexicalReference 0 #f)
(make-EnvLexicalReference 1 #f))))
(make-EnvLexicalReference 1 #f))
(current-defined-name)))
,(make-PopEnvironment 2 0)))
;; Finally, do a tail call into f.

3
il-structs.rkt
View File

@ -136,7 +136,8 @@
;; closure needs to close over.
(define-struct: MakeCompiledProcedure ([label : Symbol]
[arity : Natural]
[closed-vals : (Listof EnvReference)])
[closed-vals : (Listof EnvReference)]
[display-name : (U Symbol False)])
#:transparent)
;; Applies the primitive procedure that's stored in the proc register, using

5
runtime.js
View File

@ -152,6 +152,11 @@ var Primitives = (function() {
return firstArg - 1;
},
'zero?': function(arity, returnLabel) {
var firstArg = MACHINE.env[MACHINE.env.length-1];
return firstArg === 0;
},
'vector': function(arity, returnLabel) {
var i;
var result = [];

57
simulator-primitives.rkt
View File

@ -41,7 +41,8 @@
(define call/cc
(make-closure call/cc-label
1
'()))
'()
'call/cc))
(define call-with-current-continuation call/cc)
(define e (exp 1))
@ -66,6 +67,36 @@
(define my-pair? (lambda (x)
(MutablePair? x)))
(define my-box (lambda (x)
(vector x)))
(define my-unbox (lambda (x)
(vector-ref x 0)))
(define my-set-box! (lambda (x v)
(vector-set! x 0 v)))
(define my-vector->list (lambda (v)
(apply my-list (vector->list v))))
(define my-list->vector (lambda (l)
(apply vector
(let loop ([l l])
(cond
[(null? l)
null]
[else
(cons (MutablePair-h l)
(loop (MutablePair-t l)))])))))
(define my-set-car! (lambda (p v)
(set-MutablePair-h! p v)))
(define my-set-cdr! (lambda (p v)
(set-MutablePair-t! p v)))
(define lookup-primitive (make-lookup #:functions (+ - * / = < <= > >=
sub1
display newline displayln
@ -74,6 +105,7 @@
eq?
add1
sub1
zero?
abs
void
quotient
@ -81,14 +113,37 @@
display
displayln
newline
symbol->string
string-append
(my-cons cons)
(my-list list)
(my-car car)
(my-cdr cdr)
(my-pair? pair?)
(my-set-car! set-car!)
(my-set-cdr! set-cdr!)
(my-box box)
(my-unbox unbox)
(my-set-box! set-box!)
vector
vector-set!
vector-ref
(my-vector->list vector->list)
(my-list->vector list->vector)
equal?
symbol?)
#:constants (null pi e
call/cc

6
simulator-structs.rkt
View File

@ -24,7 +24,8 @@
(define-struct: MutablePair ([h : PrimitiveValue]
[t : PrimitiveValue]))
[t : PrimitiveValue])
#:mutable #:transparent)
;; For continuation capture:
(define-struct: CapturedControl ([frames : (Listof frame)]))
@ -70,7 +71,8 @@
;; Compiled procedure closures
(define-struct: closure ([label : Symbol]
[arity : Natural]
[vals : (Listof SlotValue)])
[vals : (Listof SlotValue)]
[display-name : (U Symbol False)])
#:transparent)

7
simulator.rkt
View File

@ -191,7 +191,9 @@
(if (= (closure-arity clos)
(CheckClosureArity!-arity op))
'ok
(error 'check-closure-arity "arity mismatch"))]
(error 'check-closure-arity "arity mismatch: passed ~s args to ~s"
(CheckClosureArity!-arity op)
(closure-display-name clos)))]
[else
(error 'check-closure-arity "not a closure: ~s" clos)]))]
@ -263,7 +265,8 @@
(MakeCompiledProcedure-arity op)
(map (lambda: ([r : EnvReference])
(lookup-env-reference/closure-capture m r))
(MakeCompiledProcedure-closed-vals op))))]
(MakeCompiledProcedure-closed-vals op))
(MakeCompiledProcedure-display-name op)))]
[(ApplyPrimitiveProcedure? op)
(let: ([prim : SlotValue (machine-proc m)]

6
test-conform.rkt
View File

@ -15,6 +15,8 @@
#:debug? (debug? false)
#:stack-limit (stack-limit false)
#:control-limit (control-limit false))
#;(for-each displayln (vector->list (machine-text m)))
(let loop ([steps 0])
(when debug?
@ -49,7 +51,7 @@
(printf "Running... \n")
(let*-values([(a-machine num-steps)
(run (new-machine (run-compiler code)) options ...)]
[(actual) (machine-val a-machine)])
[(actual) (machine-val a-machine)])
(unless (equal? actual exp)
(raise-syntax-error #f (format "Expected ~s, got ~s" exp actual)
#'stx))
@ -66,4 +68,4 @@
(test (read (open-input-file "tests/conform/program0.sch"))
(port->string (open-input-file "tests/conform/expected0.txt"))
#:debug? #t)
#:debug? #f)

74
tests/conform/program0.sch
View File

@ -1,4 +1,42 @@
(begin
(define (caar l)
(car (car l)))
(define (map f l)
(if (null? l)
null
(cons (f (car l))
(map f (cdr l)))))
(define (for-each f l)
(if (null? l)
null
(begin (f (car l))
(for-each f (cdr l)))))
(define (memq x l)
(if (null? l)
#f
(if (eq? x (car l))
l
(memq x (cdr l)))))
(define (assq x l)
(if (null? l)
#f
(if (eq? x (caar l))
(car l)
(assq x (cdr l)))))
(define (length l)
(if (null? l)
0
(add1 (length (cdr l)))))
(define vector-copy
(lambda (v)
(let ((length (vector-length v)))
@ -241,11 +279,11 @@
(define res (lambda (pair) (cdr pair)))
(define conforms?
(lambda (t1 t2)
(letrec ((nodes-with-red-edges-out '())
(letrec ((nodes-with-red-edges-out (box '()))
(add-red-edge!
(lambda (from-node to-node)
(set-red-edges! from-node (adjoin to-node (red-edges from-node)))
(set! nodes-with-red-edges-out (adjoin from-node nodes-with-red-edges-out))))
(set-box! nodes-with-red-edges-out (adjoin from-node (unbox 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)))
@ -279,7 +317,7 @@
loop)
(blue-edges t2))))))))))
(let ((result (does-conform t1 t2)))
(for-each (if result greenify-red-edges! delete-red-edges!) nodes-with-red-edges-out)
(for-each (if result greenify-red-edges! delete-red-edges!) (unbox nodes-with-red-edges-out))
result))))
(define equivalent? (lambda (a b) (if (conforms? a b) (conforms? b a) '#f)))
(define classify
@ -379,7 +417,7 @@
(if (conforms? node2 node1)
(begin node2)
(begin
(let ((result (make-node (string-append '"(" (name node1) '" v " (name node2) '")"))))
(let ((result (make-node (string-append '"(" (name node1) '" v " (name node2) '")") '())))
(add-graph-nodes! graph result)
(insert! (already-joined graph) node1 node2 result)
(set-blue-edges!
@ -411,25 +449,25 @@
(begin
(if print? (begin (display '" -> ") (display new-count) (newline)) (void))
(loop new-g new-count)))))))))
(let ((graph (apply make-graph (list (adjoin any-node (adjoin none-node (graph-nodes (clean-graph g))))))))
(let ((graph (make-graph (adjoin any-node (adjoin none-node (graph-nodes (clean-graph g)))))))
(loop graph (length (graph-nodes graph)))))))
(define a '())
(define b '())
(define c '())
(define d '())
(define a (box '()))
(define b (box '()))
(define c (box '()))
(define d (box '()))
(define reset
(lambda ()
(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)))
(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))))
'(made a b c d)))
(define test
(lambda () (reset) (map name (graph-nodes (make-lattice (make-graph (list a b c d any-node none-node)) '#t)))))
(lambda () (reset) (map name (graph-nodes (make-lattice (make-graph (list (unbox a) (unbox b) (unbox c) (unbox d) any-node none-node)) '#t)))))
(define go
(lambda ()
(reset)