diff --git a/compiler.rkt b/compiler.rkt index b1d7852..3d3d7cb 100644 --- a/compiler.rkt +++ b/compiler.rkt @@ -33,7 +33,7 @@ ;; Layout the lambda bodies... (make-instruction-sequence `(,(make-GotoStatement (make-Label after-lam-bodies)))) - (compile-lambda-bodies (collect-all-lams exp)) + (compile-lambda-bodies (collect-all-lambdas-with-bodies exp)) after-lam-bodies ;; Begin a prompted evaluation: @@ -55,9 +55,9 @@ -(: collect-all-lams (Expression -> (Listof lam+cenv))) +(: collect-all-lambdas-with-bodies (Expression -> (Listof lam+cenv))) ;; Finds all the lambdas in the expression. -(define (collect-all-lams exp) +(define (collect-all-lambdas-with-bodies exp) (let: loop : (Listof lam+cenv) ([exp : Expression exp] [cenv : CompileTimeEnvironment '()]) @@ -87,6 +87,9 @@ (loop lam cenv)) (CaseLam-clauses exp))))] + [(EmptyClosureReference? exp) + '()] + [(Seq? exp) (apply append (map (lambda: ([e : Expression]) (loop e cenv)) (Seq-actions exp)))] @@ -173,6 +176,8 @@ (compile-lambda exp cenv target linkage)] [(CaseLam? exp) (compile-case-lambda exp cenv target linkage)] + [(EmptyClosureReference? exp) + (compile-empty-closure-reference exp cenv target linkage)] [(Seq? exp) (compile-sequence (Seq-actions exp) cenv @@ -470,6 +475,25 @@ (Lam-name exp))))) singular-context-check)))) +(: compile-empty-closure-reference (EmptyClosureReference CompileTimeEnvironment Target Linkage -> InstructionSequence)) +(define (compile-empty-closure-reference exp cenv target linkage) + (let ([singular-context-check (emit-singular-context linkage)]) + (end-with-linkage + linkage + cenv + (append-instruction-sequences + (make-instruction-sequence + `(,(make-AssignPrimOpStatement + target + (make-MakeCompiledProcedure (EmptyClosureReference-entry-label exp) + (EmptyClosureReference-arity exp) + empty + (EmptyClosureReference-name exp))))) + singular-context-check)))) + + + + (: compile-case-lambda (CaseLam CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; Similar to compile-lambda. (define (compile-case-lambda exp cenv target linkage) @@ -523,6 +547,15 @@ (Lam-num-parameters lam))) +(: EmptyClosureReference-arity (EmptyClosureReference -> Arity)) +(define (EmptyClosureReference-arity lam) + (if (EmptyClosureReference-rest? lam) + (make-ArityAtLeast (EmptyClosureReference-num-parameters lam)) + (EmptyClosureReference-num-parameters lam))) + + + + (: shift-closure-map ((Listof Natural) Natural -> (Listof Natural))) (define (shift-closure-map closure-map n) (map (lambda: ([i : Natural]) (+ i n)) @@ -1860,6 +1893,9 @@ (CaseLam-clauses exp)) (CaseLam-entry-label exp))] + [(EmptyClosureReference? exp) + exp] + [(Seq? exp) (make-Seq (map (lambda: ([action : Expression]) (adjust-expression-depth action n skip)) diff --git a/expression-structs.rkt b/expression-structs.rkt index d47d597..09437b9 100644 --- a/expression-structs.rkt +++ b/expression-structs.rkt @@ -12,8 +12,9 @@ LocalRef ToplevelSet Branch - CaseLam Lam + CaseLam + EmptyClosureReference Seq Splice App @@ -73,6 +74,15 @@ [closure-map : (Listof Natural)] [entry-label : Symbol]) #:transparent) +;; An EmptyClosureReference has enough information to create the lambda value, +;; assuming that the lambda's body has already been compiled. The entry-label needs +;; to have been shared with an existing Lam, and the closure must be empty. +(define-struct: EmptyClosureReference ([name : (U Symbol LamPositionalName)] + [num-parameters : Natural] + [rest? : Boolean] + [entry-label : Symbol]) #:transparent) + + ;; We may have more information about the lambda's name. This will show it. (define-struct: LamPositionalName ([name : Symbol] diff --git a/parse-bytecode-5.1.1.rkt b/parse-bytecode-5.1.1.rkt index 5923d75..af2fefa 100644 --- a/parse-bytecode-5.1.1.rkt +++ b/parse-bytecode-5.1.1.rkt @@ -30,14 +30,17 @@ (error 'current-module-path-index-resolver)))) -;; seen-lambdas: -(define seen-lambdas (make-parameter (make-hasheq))) +;; seen-closures: (hashof symbol -> symbol) +;; As we're parsing, we watch for closure cycles. On any subsequent time where +;; we see a closure cycle, we break the cycle by generating an EmptyClosureReference. +;; The map is from the gen-id to the entry-point label of the lambda. +(define seen-closures (make-parameter (make-hasheq))) ;; parse-bytecode: Input-Port -> Expression (define (parse-bytecode in) - (parameterize ([seen-lambdas (make-hasheq)]) + (parameterize ([seen-closures (make-hasheq)]) (let ([compilation-top (zo-parse in)]) (parse-top compilation-top)))) @@ -239,7 +242,7 @@ (define (parse-expr expr) (cond [(lam? expr) - (parse-lam expr)] + (parse-lam expr (make-label 'lamEntry))] [(closure? expr) (parse-closure expr)] [(case-lam? expr) @@ -277,37 +280,16 @@ [(primval? expr) (parse-primval expr)])) -(define (parse-lam expr) +(define (parse-lam expr entry-point-label) (match expr [(struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body)) - (let ([lam-name (cond - [(symbol? name) - name] - [(vector? name) - (match name - [(vector (and (? symbol?) sym) - (and (? path?) path) - (and (? number?) line) - (and (? number?) column) - (and (? number?) offset) - (and (? number?) span) - _) - (make-LamPositionalName sym - (path->string path) - line - column - offset - span)] - [else - (string->symbol (format "~s" name))])] - [else - (error "lam name neither symbol nor vector: ~e" name)])]) + (let ([lam-name (extract-lam-name name)]) (make-Lam lam-name num-params rest? (parse-lam-body body) (vector->list closure-map) - (make-label 'lamEntry)))])) + entry-point-label))])) (define (parse-lam-body body) (cond @@ -319,12 +301,54 @@ (make-Constant body)])) - +;; parse-closure: closure -> Expression +;; Either parses as a regular lambda, or if we come across the same closure twice, +;; breaks the cycle by creating an EmptyClosureReference with the pre-existing lambda +;; entry point. (define (parse-closure expr) (match expr [(struct closure (code gen-id)) - ;; Fixme: we must handle cycles here. - (parse-lam code)])) + (let ([seen (seen-closures)]) + (cond + [(hash-has-key? seen gen-id) + (match code + [(struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body)) + (let ([lam-name (extract-lam-name name)]) + (make-EmptyClosureReference lam-name + num-params + rest? + (hash-ref seen gen-id)))])] + [else + (let ([fresh-entry-point (make-label 'lamEntry)]) + (hash-set! seen gen-id fresh-entry-point) + (parse-lam code fresh-entry-point))]))])) + + + +;; extract-lam-name: (U Symbol Vector) -> (U Symbol LamPositionalName) +(define (extract-lam-name name) + (cond + [(symbol? name) + name] + [(vector? name) + (match name + [(vector (and (? symbol?) sym) + (and (? path?) path) + (and (? number?) line) + (and (? number?) column) + (and (? number?) offset) + (and (? number?) span) + _) + (make-LamPositionalName sym + (path->string path) + line + column + offset + span)] + [else + (string->symbol (format "~s" name))])] + [else + (error "lam name neither symbol nor vector: ~e" name)])) (define (parse-case-lam exp) @@ -363,8 +387,33 @@ (define (parse-topsyntax expr) (error 'fixme)) + (define (parse-application expr) - (error 'fixme)) + (match expr + [(struct application (rator rands)) + (make-App (parse-application-rator rator) + (map parse-application-rand rands))])) + +(define (parse-application-rator rator) + (cond + [(expr? rator) + (parse-expr rator)] + [(seq? rator) + (parse-seq rator)] + [else + (make-Constant rator)])) + +(define (parse-application-rand rand) + (cond + [(expr? rand) + (parse-expr rand)] + [(seq? rand) + (parse-seq rand)] + [else + (make-Constant rand)])) + + + (define (parse-branch expr) (error 'fixme)) diff --git a/test-parse-bytecode-5.1.1.rkt b/test-parse-bytecode-5.1.1.rkt index 0199396..262cf7d 100644 --- a/test-parse-bytecode-5.1.1.rkt +++ b/test-parse-bytecode-5.1.1.rkt @@ -93,9 +93,14 @@ -;; infinite loop +;; make sure we don't see an infinite loop #;(run-zo-parse #'(letrec ([g (lambda () (g))]) (g))) +(void (run-my-parse #'(letrec ([g (lambda () (g))]) + (g)))) + + + #;(run-zo-parse #'(letrec ([g (lambda () (h))] [h (lambda () (g))]) (g)))