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

fixing implementation of letrec, which isn't supposed to do any allocation. That's the job of letvoid

Browse Source
This commit is contained in:
Danny Yoo 2011-05-09 23:39:03 -04:00
parent 39935eaee3
commit e3d8a253fe
5 changed files with 116 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
compiler.rkt
View File

@ -116,19 +116,20 @@
[(BoxEnv? exp)
(loop (BoxEnv-body exp) cenv)]
[(LetRec? exp)
(let ([new-cenv (append (map (lambda: ([p : Lam])
(extract-static-knowledge
p
(append (build-list (length (LetRec-procs exp))
(lambda: ([i : Natural]) '?))
cenv)))
(reverse (LetRec-procs exp)))
cenv)])
(append (apply append
(map (lambda: ([lam : Lam])
(loop lam new-cenv))
(LetRec-procs exp)))
(loop (LetRec-body exp) new-cenv)))]
(let ([n (length (LetRec-procs exp))])
(let ([new-cenv (append (map (lambda: ([p : Lam])
(extract-static-knowledge
p
(append (build-list (length (LetRec-procs exp))
(lambda: ([i : Natural]) '?))
(drop cenv n))))
(reverse (LetRec-procs exp)))
(drop cenv n))])
(append (apply append
(map (lambda: ([lam : Lam])
(loop lam new-cenv))
(LetRec-procs exp)))
(loop (LetRec-body exp) new-cenv))))]
[(WithContMark? exp)
(append (loop (WithContMark-key exp) cenv)
(loop (WithContMark-value exp) cenv)
@ -1514,16 +1515,17 @@
;; Compiled recursive Lams. Each lambda is installed as a shell, and then the closures
;; are installed in-place.
(define (compile-let-rec exp cenv target linkage)
(let*: ([extended-cenv : CompileTimeEnvironment
(let*: ([n : Natural (length (LetRec-procs exp))]
[extended-cenv : CompileTimeEnvironment
(append (map (lambda: ([p : Lam])
(extract-static-knowledge
p
(append (build-list (length (LetRec-procs exp))
(lambda: ([i : Natural])
'?))
cenv)))
(drop cenv n))))
(reverse (LetRec-procs exp)))
cenv)]
(drop cenv n))]
[n : Natural (length (LetRec-procs exp))]
[after-body-code : Symbol (make-label 'afterBodyCode)]
[letrec-linkage : Linkage (cond
@ -1543,8 +1545,6 @@
linkage
extended-cenv
(append-instruction-sequences
(make-instruction-sequence
`(,(make-PushEnvironment n #f)))
;; Install each of the closure shells
(apply append-instruction-sequences
@ -1569,11 +1569,9 @@
(build-list n (lambda: ([i : Natural]) (ensure-natural (- n 1 i))))))
;; Compile the body
(compile (LetRec-body exp) extended-cenv (adjust-target-depth target n) letrec-linkage)
(compile (LetRec-body exp) extended-cenv target letrec-linkage)
after-body-code
(make-instruction-sequence `(,(make-PopEnvironment (make-Const n) (make-Const 0))))))))
after-body-code))))

43
parse-bytecode-5.1.1.rkt
View File

@ -10,7 +10,8 @@
racket/list)
(provide parse-bytecode
current-module-path-index-resolver)
current-module-path-index-resolver
reset-lam-label-counter!/unit-testing)
;; The module-path-index of self is:
@ -264,12 +265,23 @@
(make-splice (map parse-item body))))
(define-values (make-lam-label reset-lam-label-counter!/unit-testing)
(let ([n 0])
(values
(lambda ()
(set! n (add1 n))
(string->symbol (format "lamEntry~a" n)))
(lambda ()
(set! n 0)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (parse-expr expr)
(cond
[(lam? expr)
(parse-lam expr (make-label 'lamEntry))]
(parse-lam expr (make-lam-label))]
[(closure? expr)
(parse-closure expr)]
[(case-lam? expr)
@ -337,7 +349,7 @@
rest?
(hash-ref seen gen-id)))])]
[else
(let ([fresh-entry-point (make-label 'lamEntry)])
(let ([fresh-entry-point (make-lam-label)])
(hash-set! seen gen-id fresh-entry-point)
(parse-lam code fresh-entry-point))]))]))
@ -370,7 +382,7 @@
(define (parse-case-lam exp)
(error 'fixme))
(error 'fixmecaselam))
(define (parse-let-one expr)
(match expr
@ -389,16 +401,23 @@
(define (parse-let-void expr)
(error 'fixme))
(match expr
[(struct let-void (count boxes? body))
(make-LetVoid count (parse-expr-seq-constant body) boxes?)]))
(define (parse-install-value expr)
(error 'fixme))
(error 'fixmeinstallvalue))
(define (parse-let-rec expr)
(error 'fixme))
(match expr
[(struct let-rec (procs body))
(make-LetRec (map (lambda (p) (parse-lam p (make-lam-label)))
procs)
(parse-expr-seq-constant body))]))
(define (parse-boxenv expr)
(error 'fixme))
(error 'fixmeboxenv))
(define (parse-localref expr)
(match expr
@ -456,16 +475,16 @@
(error 'fixme))
(define (parse-beg0 expr)
(error 'fixme))
(error 'fixmebeg0))
(define (parse-varref expr)
(error 'fixme))
(error 'fixmevarref))
(define (parse-assign expr)
(error 'fixme))
(error 'fixmeassign))
(define (parse-apply-values expr)
(error 'fixme))
(error 'fixmeapplyvalues))
(define (parse-primval expr)

14
parse.rkt
View File

@ -616,7 +616,7 @@
any-mutated?))])))
;; Letrec's currently doing a set! kind of thing.
;; Letrec: recursive let bindings
(define (parse-letrec exp cenv)
(let* ([vars (let-variables exp)]
[rhss (let-rhss exp)]
@ -636,11 +636,13 @@
;; Semantics: allocate a closure shell for each lambda form in procs.
;; Install them in reverse order, so that the closure shell for the last element
;; in procs is at stack position 0.
(make-LetRec (map (lambda (rhs name) (parameterize ([current-defined-name name])
(parse rhs new-cenv #f)))
rhss
vars)
(parse `(begin ,@body) new-cenv #f)))]
(make-LetVoid (length vars)
(make-LetRec (map (lambda (rhs name) (parameterize ([current-defined-name name])
(parse rhs new-cenv #f)))
rhss
vars)
(parse `(begin ,@body) new-cenv #f))
#f))]
[else
(let ([new-cenv (extend-lexical-environment/boxed-names cenv (reverse vars))])
(make-LetVoid (length vars)

45
test-parse-bytecode-5.1.1.rkt
View File

@ -173,6 +173,51 @@
(make-PrimitiveKernelValue '+)))
(check-equal? (run-my-parse #'(+ (* x x) x))
(make-Top (make-Prefix (list (make-GlobalBucket 'x)))
(make-App (make-PrimitiveKernelValue '+)
(list (make-App (make-PrimitiveKernelValue '*)
(list (make-ToplevelRef 4 0)
(make-ToplevelRef 4 0)))
(make-ToplevelRef 2 0)))))
(check-equal? (run-my-parse #'list)
(make-Top (make-Prefix (list))
(make-PrimitiveKernelValue 'list)))
(check-equal? (run-my-parse #'append)
(make-Top (make-Prefix (list))
(make-PrimitiveKernelValue 'append)))
(check-equal? (run-my-parse #'(let () x))
(make-Top (make-Prefix (list (make-GlobalBucket 'x)))
(make-ToplevelRef 0 0)))
;; the letrec gets translated into a closure call
(begin
(reset-lam-label-counter!/unit-testing)
(check-equal? (run-my-parse '(letrec ([omega (lambda () (omega))])
(omega)))
(make-Top (make-Prefix '())
(make-App (make-Lam 'omega 0 #f (make-App (make-EmptyClosureReference 'omega 0 #f 'lamEntry1) '())
'() 'lamEntry1)
'()))))
(run-my-parse #'(letrec ([e (lambda (y)
(if (= y 0)
#t
(o (sub1 y))))]
[o (lambda (y)
(if (= y 0)
#f
(e sub1 y)))])
e))
;; make sure we don't see an infinite loop
#;(run-zo-parse #'(letrec ([g (lambda () (g))])

20
test-parse.rkt
View File

@ -318,9 +318,11 @@
(test (parse '(letrec ([omega (lambda () (omega))])
(omega)))
(make-Top (make-Prefix '())
(make-LetRec (list (make-Lam 'omega 0 #f (make-App (make-LocalRef 0 #f)
(list)) '(0) 'lamEntry1))
(make-App (make-LocalRef 0 #f) (list)))))
(make-LetVoid 1
(make-LetRec (list (make-Lam 'omega 0 #f (make-App (make-LocalRef 0 #f)
(list)) '(0) 'lamEntry1))
(make-App (make-LocalRef 0 #f) (list)))
#f)))
@ -329,11 +331,13 @@
[c (lambda () (a))])
(a)))
(make-Top (make-Prefix '())
(make-LetRec (list (make-Lam 'a 0 #f (make-App (make-LocalRef 0 #f) '()) '(1) 'lamEntry1)
(make-Lam 'b 0 #f (make-App (make-LocalRef 0 #f) '()) '(0) 'lamEntry2)
(make-Lam 'c 0 #f (make-App (make-LocalRef 0 #f) '()) '(2) 'lamEntry3))
(make-App (make-LocalRef 2 #f) '()))))
(make-LetVoid 3
(make-LetRec (list (make-Lam 'a 0 #f (make-App (make-LocalRef 0 #f) '()) '(1) 'lamEntry1)
(make-Lam 'b 0 #f (make-App (make-LocalRef 0 #f) '()) '(0) 'lamEntry2)
(make-Lam 'c 0 #f (make-App (make-LocalRef 0 #f) '()) '(2) 'lamEntry3))
(make-App (make-LocalRef 2 #f) '()))
#f)))
(test (parse '(letrec ([x (lambda (x) x)]