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

43
parse-bytecode-5.1.1.rkt
View File

@ -10,7 +10,8 @@
racket/list) racket/list)
(provide parse-bytecode (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: ;; The module-path-index of self is:
@ -264,12 +265,23 @@
(make-splice (map parse-item body)))) (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) (define (parse-expr expr)
(cond (cond
[(lam? expr) [(lam? expr)
(parse-lam expr (make-label 'lamEntry))] (parse-lam expr (make-lam-label))]
[(closure? expr) [(closure? expr)
(parse-closure expr)] (parse-closure expr)]
[(case-lam? expr) [(case-lam? expr)
@ -337,7 +349,7 @@
rest? rest?
(hash-ref seen gen-id)))])] (hash-ref seen gen-id)))])]
[else [else
(let ([fresh-entry-point (make-label 'lamEntry)]) (let ([fresh-entry-point (make-lam-label)])
(hash-set! seen gen-id fresh-entry-point) (hash-set! seen gen-id fresh-entry-point)
(parse-lam code fresh-entry-point))]))])) (parse-lam code fresh-entry-point))]))]))
@ -370,7 +382,7 @@
(define (parse-case-lam exp) (define (parse-case-lam exp)
(error 'fixme)) (error 'fixmecaselam))
(define (parse-let-one expr) (define (parse-let-one expr)
(match expr (match expr
@ -389,16 +401,23 @@
(define (parse-let-void expr) (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) (define (parse-install-value expr)
(error 'fixme)) (error 'fixmeinstallvalue))
(define (parse-let-rec expr) (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) (define (parse-boxenv expr)
(error 'fixme)) (error 'fixmeboxenv))
(define (parse-localref expr) (define (parse-localref expr)
(match expr (match expr
@ -456,16 +475,16 @@
(error 'fixme)) (error 'fixme))
(define (parse-beg0 expr) (define (parse-beg0 expr)
(error 'fixme)) (error 'fixmebeg0))
(define (parse-varref expr) (define (parse-varref expr)
(error 'fixme)) (error 'fixmevarref))
(define (parse-assign expr) (define (parse-assign expr)
(error 'fixme)) (error 'fixmeassign))
(define (parse-apply-values expr) (define (parse-apply-values expr)
(error 'fixme)) (error 'fixmeapplyvalues))
(define (parse-primval expr) (define (parse-primval expr)

14
parse.rkt
View File

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

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

@ -173,6 +173,51 @@
(make-PrimitiveKernelValue '+))) (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 ;; make sure we don't see an infinite loop
#;(run-zo-parse #'(letrec ([g (lambda () (g))]) #;(run-zo-parse #'(letrec ([g (lambda () (g))])

20
test-parse.rkt
View File

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