diff --git a/compiler.rkt b/compiler.rkt index dd6fa9e..57ca0a7 100644 --- a/compiler.rkt +++ b/compiler.rkt @@ -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)))) diff --git a/parse-bytecode-5.1.1.rkt b/parse-bytecode-5.1.1.rkt index 0fbf39e..20d4f3a 100644 --- a/parse-bytecode-5.1.1.rkt +++ b/parse-bytecode-5.1.1.rkt @@ -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) diff --git a/parse.rkt b/parse.rkt index 82359b5..ff377c4 100644 --- a/parse.rkt +++ b/parse.rkt @@ -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) diff --git a/test-parse-bytecode-5.1.1.rkt b/test-parse-bytecode-5.1.1.rkt index a8583c2..103d9fe 100644 --- a/test-parse-bytecode-5.1.1.rkt +++ b/test-parse-bytecode-5.1.1.rkt @@ -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))]) diff --git a/test-parse.rkt b/test-parse.rkt index 8e64d65..6ccb0db 100644 --- a/test-parse.rkt +++ b/test-parse.rkt @@ -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)]