diff --git a/compile.rkt b/compile.rkt index b772d0f..d9e5034 100644 --- a/compile.rkt +++ b/compile.rkt @@ -12,15 +12,24 @@ +;; We try to keep at compile time a mapping from environment positions to +;; statically known things, to generate better code. +(define-struct: StaticallyKnownLam ([entry : Symbol] + [arity : Natural]) #:transparent) +(define-type CompileTimeEnvironmentEntry (U '? 'prefix StaticallyKnownLam)) +(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry)) + + + (: -compile (ExpressionCore Target Linkage -> (Listof Statement))) (define (-compile exp target linkage) - (statements - (compile exp - '() - target - linkage))) + (statements + (compile exp + '() + target + linkage))) @@ -207,7 +216,7 @@ ;; Write out code for lambda expressions. ;; The lambda will close over the free variables. (define (compile-lambda exp cenv target linkage) - (let*: ([proc-entry : Symbol (make-label 'entry)] + (let*: ([proc-entry : Symbol (Lam-entry-label exp) #;(make-label 'entry)] [after-lambda : Symbol (make-label 'afterLambda)] [lambda-linkage : Linkage (if (eq? linkage 'next) @@ -250,11 +259,6 @@ ;; 2. We may have a static location to jump to if the operator is lexically scoped. (: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-application exp cenv target linkage) - (let ([operator (App-operator exp)]) - (cond - ;; FIXME: add special cases here. - - [else (let* ([extended-cenv (append (map (lambda: ([op : ExpressionCore]) '?) (App-operands exp)) @@ -281,10 +285,22 @@ (make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f))) proc-code (juggle-operands operand-codes) - (compile-procedure-call cenv - extended-cenv - (length (App-operands exp)) - target linkage)))]))) + + (let: ([operator : ExpressionCore (App-operator exp)]) + (cond + [(and (LocalRef? operator) (not (LocalRef-unbox? operator))) + (printf "I statically know the operator is: ~s\n" + (list-ref extended-cenv (LocalRef-depth operator))) + (compile-procedure-call/statically-known-lam extended-cenv + (length (App-operands exp)) + target + linkage)] + + [else + (compile-procedure-call cenv + extended-cenv + (length (App-operands exp)) + target linkage)]))))) @@ -359,6 +375,15 @@ after-call)))) +(: compile-procedure-call/statically-known-lam + (CompileTimeEnvironment Natural Target Linkage -> InstructionSequence)) +(define (compile-procedure-call/statically-known-lam extended-cenv n target linkage) + (end-with-compiled-application-linkage + linkage + extended-cenv + (compile-proc-appl extended-cenv n target linkage))) + + (: compile-proc-appl (CompileTimeEnvironment Natural Target Linkage -> InstructionSequence)) ;; Three fundamental cases for general compiled-procedure application. @@ -409,16 +434,26 @@ (error 'compile "return linkage, target not val: ~s" target)])) +(: extract-static-knowledge (ExpressionCore -> CompileTimeEnvironmentEntry)) +(define (extract-static-knowledge exp) + (cond + [(Lam? exp) + (make-StaticallyKnownLam (Lam-entry-label exp) + (Lam-num-parameters exp))] + [else + '?])) + + (: compile-let1 (Let1 CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-let1 exp cenv target linkage) (let*: ([rhs-code : InstructionSequence (compile (Let1-rhs exp) - (cons '? cenv) - (make-EnvLexicalReference 0 #f) - 'next)] + (cons '? cenv) + (make-EnvLexicalReference 0 #f) + 'next)] [after-let1 : Symbol (make-label 'afterLetOne)] [after-body-code : Symbol (make-label 'afterLetBody)] - [extended-cenv : CompileTimeEnvironment (cons '? cenv)] + [extended-cenv : CompileTimeEnvironment (cons (extract-static-knowledge (Let1-rhs exp)) cenv)] [let-linkage : Linkage (cond [(eq? linkage 'next) @@ -449,7 +484,7 @@ [after-let : Symbol (make-label 'afterLet)] [after-body-code : Symbol (make-label 'afterLetBody)] [extended-cenv : CompileTimeEnvironment (append (build-list (LetVoid-count exp) - (lambda: ([i : Natural]) '?)) + (lambda: ([i : Natural]) '?)) cenv)] [let-linkage : Linkage (cond @@ -536,4 +571,3 @@ -(define-type CompileTimeEnvironment (Listof (U '? 'prefix))) \ No newline at end of file diff --git a/expression-structs.rkt b/expression-structs.rkt index fe7ae61..cc77352 100644 --- a/expression-structs.rkt +++ b/expression-structs.rkt @@ -39,7 +39,8 @@ (define-struct: Lam ([name : (U Symbol False)] [num-parameters : Natural] [body : ExpressionCore] - [closure-map : (Listof Natural)]) #:transparent) + [closure-map : (Listof Natural)] + [entry-label : Symbol]) #:transparent) (define-struct: Seq ([actions : (Listof ExpressionCore)]) #:transparent) (define-struct: App ([operator : ExpressionCore] diff --git a/parse.rkt b/parse.rkt index 92354f4..99e7173 100644 --- a/parse.rkt +++ b/parse.rkt @@ -7,7 +7,10 @@ "parameters.rkt" racket/list) -(provide (rename-out (-parse parse))) +(provide (rename-out (-parse parse)) + + ;; meant for tests + set-private-lam-label-counter!) (define (-parse exp) (let* ([prefix (make-Prefix (find-unbound-names exp))]) @@ -141,7 +144,17 @@ (make-Lam (current-defined-name) (length (lambda-parameters exp)) lam-body - (map env-reference-depth closure-references))))) + (map env-reference-depth closure-references) + (fresh-lam-label))))) + + +(define lam-label-counter 0) +(define (set-private-lam-label-counter! x) + (set! lam-label-counter x)) +(define fresh-lam-label + (lambda () + (set! lam-label-counter (add1 lam-label-counter)) + (string->symbol (format "lamEntry~a" lam-label-counter)))) (define (seq codes) diff --git a/test-parse.rkt b/test-parse.rkt index 668eec4..9f1a997 100644 --- a/test-parse.rkt +++ b/test-parse.rkt @@ -13,6 +13,7 @@ (syntax/loc #'stx (begin (printf "Running ~s ...\n" (syntax->datum #'expr)) + (set-private-lam-label-counter! 0) (let ([expected expt] [actual (with-handlers ([void @@ -88,15 +89,15 @@ (test (parse '(lambda (x y z) x)) (make-Top (make-Prefix '()) - (make-Lam #f 3 (make-LocalRef 0 #f) '()))) + (make-Lam #f 3 (make-LocalRef 0 #f) '() 'lamEntry1))) (test (parse '(lambda (x y z) y)) (make-Top (make-Prefix '()) - (make-Lam #f 3 (make-LocalRef 1 #f) '()))) + (make-Lam #f 3 (make-LocalRef 1 #f) '() 'lamEntry1))) (test (parse '(lambda (x y z) z)) (make-Top (make-Prefix '()) - (make-Lam #f 3 (make-LocalRef 2 #f) '()))) + (make-Lam #f 3 (make-LocalRef 2 #f) '() 'lamEntry1))) (test (parse '(lambda (x y z) x y z)) @@ -104,14 +105,16 @@ (make-Lam #f 3 (make-Seq (list (make-LocalRef 0 #f) (make-LocalRef 1 #f) (make-LocalRef 2 #f))) - '()))) + '() + 'lamEntry1))) (test (parse '(lambda (x y z) k)) (make-Top (make-Prefix '(k)) (make-Lam #f 3 (make-ToplevelRef 0 0 ) - '(0)))) + '(0) + 'lamEntry1))) (test (parse '(lambda (x y z) k x y z)) (make-Top (make-Prefix '(k)) @@ -120,7 +123,8 @@ (make-LocalRef 1 #f) (make-LocalRef 2 #f) (make-LocalRef 3 #f))) - '(0)))) + '(0) + 'lamEntry1))) (test (parse '(lambda (x) (lambda (y) @@ -139,11 +143,12 @@ (make-LocalRef 3 #f) (make-ToplevelRef 0 0))) '(0 1 2) ;; w x y - ) + 'lamEntry1) '(0 1) ;; w x - ) - '(0)))) + 'lamEntry2) + '(0) + 'lamEntry3))) (test (parse '(lambda (x) (lambda (y) @@ -152,8 +157,10 @@ (make-Lam #f 1 (make-Lam #f 1 (make-LocalRef 0 #f) - '(0)) - (list)))) + '(0) + 'lamEntry1) + (list) + 'lamEntry2))) (test (parse '(lambda (x) (lambda (y) @@ -162,8 +169,10 @@ (make-Lam #f 1 (make-Lam #f 1 (make-LocalRef 0 #f) - (list)) - (list)))) + (list) + 'lamEntry1) + (list) + 'lamEntry2))) (test (parse '(+ x x)) (make-Top (make-Prefix '(+ x)) @@ -178,7 +187,8 @@ (make-App (make-ToplevelRef 2 0) (list (make-LocalRef 3 #f) (make-LocalRef 3 #f))) - '(0)))) + '(0) + 'lamEntry1))) (test (parse '(lambda (x) (+ (* x x) x))) @@ -192,7 +202,8 @@ (list (make-LocalRef 5 #f) (make-LocalRef 5 #f))) (make-LocalRef 3 #f))) - '(0)))) + '(0) + 'lamEntry1))) (test (parse '(let () x)) @@ -275,10 +286,10 @@ (make-Seq (list (make-InstallValue 0 - (make-Lam 'x 1 (make-LocalRef 0 #f) '()) + (make-Lam 'x 1 (make-LocalRef 0 #f) '() 'lamEntry1) #t) (make-InstallValue 1 - (make-Lam 'y 1 (make-LocalRef 0 #f) '()) + (make-Lam 'y 1 (make-LocalRef 0 #f) '() 'lamEntry2) #t) ;; stack layout: ??? x y (make-App (make-LocalRef 1 #t) @@ -297,13 +308,15 @@ (make-Lam 'x 1 (make-App (make-LocalRef 1 #t) (list (make-LocalRef 2 #f))) - '(1)) + '(1) + 'lamEntry1) #t) (make-InstallValue 1 (make-Lam 'y 1 (make-App (make-LocalRef 2 #f) (list (make-LocalRef 1 #t))) - '(1)) + '(1) + 'lamEntry2) #t) ;; stack layout: ??? x y (make-App (make-LocalRef 1 #t) @@ -323,7 +336,8 @@ (list (make-LocalRef 2 #t))) #t) (make-Constant (void)))) - '(1 0)))))) ;; x is 0, prefix is 1 + '(1 0) + 'lamEntry1))))) ;; x is 0, prefix is 1 @@ -344,7 +358,8 @@ (list (make-LocalRef 2 #t))) #t) (make-Constant (void)))) - '(2 0)))) + '(2 0) + 'lamEntry1))) #t))) @@ -374,6 +389,7 @@ (list (make-Seq (list (make-ToplevelSet 0 0 'a (make-Constant '())) (make-Constant (void)))) (make-Seq (list (make-ToplevelSet 0 1 'b (make-Constant '())) (make-Constant (void)))))) - '(0))) + '(0) + 'lamEntry1)) (make-App (make-ToplevelRef 0 3) '()) (make-App (make-ToplevelRef 2 2) (list (make-ToplevelRef 2 0) (make-ToplevelRef 2 1))))))) \ No newline at end of file