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

trying to do some very simplistic static analysis

Browse Source
This commit is contained in:
Danny Yoo 2011-03-23 21:43:41 -04:00
parent 97762a015f
commit 15a03bba7c
4 changed files with 110 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

76
compile.rkt
View File

@ -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))) (: -compile (ExpressionCore Target Linkage -> (Listof Statement)))
(define (-compile exp target linkage) (define (-compile exp target linkage)
(statements (statements
(compile exp (compile exp
'() '()
target target
linkage))) linkage)))
@ -207,7 +216,7 @@
;; Write out code for lambda expressions. ;; Write out code for lambda expressions.
;; The lambda will close over the free variables. ;; The lambda will close over the free variables.
(define (compile-lambda exp cenv target linkage) (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)] [after-lambda : Symbol (make-label 'afterLambda)]
[lambda-linkage : Linkage [lambda-linkage : Linkage
(if (eq? linkage 'next) (if (eq? linkage 'next)
@ -250,11 +259,6 @@
;; 2. We may have a static location to jump to if the operator is lexically scoped. ;; 2. We may have a static location to jump to if the operator is lexically scoped.
(: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-application exp cenv target linkage) (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]) (let* ([extended-cenv (append (map (lambda: ([op : ExpressionCore])
'?) '?)
(App-operands exp)) (App-operands exp))
@ -281,10 +285,22 @@
(make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f))) (make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f)))
proc-code proc-code
(juggle-operands operand-codes) (juggle-operands operand-codes)
(compile-procedure-call cenv
extended-cenv (let: ([operator : ExpressionCore (App-operator exp)])
(length (App-operands exp)) (cond
target linkage)))]))) [(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)))) 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)) (: compile-proc-appl (CompileTimeEnvironment Natural Target Linkage -> InstructionSequence))
;; Three fundamental cases for general compiled-procedure application. ;; Three fundamental cases for general compiled-procedure application.
@ -409,16 +434,26 @@
(error 'compile "return linkage, target not val: ~s" target)])) (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)) (: compile-let1 (Let1 CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-let1 exp cenv target linkage) (define (compile-let1 exp cenv target linkage)
(let*: ([rhs-code : InstructionSequence (let*: ([rhs-code : InstructionSequence
(compile (Let1-rhs exp) (compile (Let1-rhs exp)
(cons '? cenv) (cons '? cenv)
(make-EnvLexicalReference 0 #f) (make-EnvLexicalReference 0 #f)
'next)] 'next)]
[after-let1 : Symbol (make-label 'afterLetOne)] [after-let1 : Symbol (make-label 'afterLetOne)]
[after-body-code : Symbol (make-label 'afterLetBody)] [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 [let-linkage : Linkage
(cond (cond
[(eq? linkage 'next) [(eq? linkage 'next)
@ -449,7 +484,7 @@
[after-let : Symbol (make-label 'afterLet)] [after-let : Symbol (make-label 'afterLet)]
[after-body-code : Symbol (make-label 'afterLetBody)] [after-body-code : Symbol (make-label 'afterLetBody)]
[extended-cenv : CompileTimeEnvironment (append (build-list (LetVoid-count exp) [extended-cenv : CompileTimeEnvironment (append (build-list (LetVoid-count exp)
(lambda: ([i : Natural]) '?)) (lambda: ([i : Natural]) '?))
cenv)] cenv)]
[let-linkage : Linkage [let-linkage : Linkage
(cond (cond
@ -536,4 +571,3 @@
(define-type CompileTimeEnvironment (Listof (U '? 'prefix)))

3
expression-structs.rkt
View File

@ -39,7 +39,8 @@
(define-struct: Lam ([name : (U Symbol False)] (define-struct: Lam ([name : (U Symbol False)]
[num-parameters : Natural] [num-parameters : Natural]
[body : ExpressionCore] [body : ExpressionCore]
[closure-map : (Listof Natural)]) #:transparent) [closure-map : (Listof Natural)]
[entry-label : Symbol]) #:transparent)
(define-struct: Seq ([actions : (Listof ExpressionCore)]) #:transparent) (define-struct: Seq ([actions : (Listof ExpressionCore)]) #:transparent)
(define-struct: App ([operator : ExpressionCore] (define-struct: App ([operator : ExpressionCore]

17
parse.rkt
View File

@ -7,7 +7,10 @@
"parameters.rkt" "parameters.rkt"
racket/list) racket/list)
(provide (rename-out (-parse parse))) (provide (rename-out (-parse parse))
;; meant for tests
set-private-lam-label-counter!)
(define (-parse exp) (define (-parse exp)
(let* ([prefix (make-Prefix (find-unbound-names exp))]) (let* ([prefix (make-Prefix (find-unbound-names exp))])
@ -141,7 +144,17 @@
(make-Lam (current-defined-name) (make-Lam (current-defined-name)
(length (lambda-parameters exp)) (length (lambda-parameters exp))
lam-body 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) (define (seq codes)

60
test-parse.rkt
View File

@ -13,6 +13,7 @@
(syntax/loc #'stx (syntax/loc #'stx
(begin (begin
(printf "Running ~s ...\n" (syntax->datum #'expr)) (printf "Running ~s ...\n" (syntax->datum #'expr))
(set-private-lam-label-counter! 0)
(let ([expected expt] (let ([expected expt]
[actual [actual
(with-handlers ([void (with-handlers ([void
@ -88,15 +89,15 @@
(test (parse '(lambda (x y z) x)) (test (parse '(lambda (x y z) x))
(make-Top (make-Prefix '()) (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)) (test (parse '(lambda (x y z) y))
(make-Top (make-Prefix '()) (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)) (test (parse '(lambda (x y z) z))
(make-Top (make-Prefix '()) (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)) (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-Lam #f 3 (make-Seq (list (make-LocalRef 0 #f)
(make-LocalRef 1 #f) (make-LocalRef 1 #f)
(make-LocalRef 2 #f))) (make-LocalRef 2 #f)))
'()))) '()
'lamEntry1)))
(test (parse '(lambda (x y z) k)) (test (parse '(lambda (x y z) k))
(make-Top (make-Prefix '(k)) (make-Top (make-Prefix '(k))
(make-Lam #f (make-Lam #f
3 3
(make-ToplevelRef 0 0 ) (make-ToplevelRef 0 0 )
'(0)))) '(0)
'lamEntry1)))
(test (parse '(lambda (x y z) k x y z)) (test (parse '(lambda (x y z) k x y z))
(make-Top (make-Prefix '(k)) (make-Top (make-Prefix '(k))
@ -120,7 +123,8 @@
(make-LocalRef 1 #f) (make-LocalRef 1 #f)
(make-LocalRef 2 #f) (make-LocalRef 2 #f)
(make-LocalRef 3 #f))) (make-LocalRef 3 #f)))
'(0)))) '(0)
'lamEntry1)))
(test (parse '(lambda (x) (test (parse '(lambda (x)
(lambda (y) (lambda (y)
@ -139,11 +143,12 @@
(make-LocalRef 3 #f) (make-LocalRef 3 #f)
(make-ToplevelRef 0 0))) (make-ToplevelRef 0 0)))
'(0 1 2) ;; w x y '(0 1 2) ;; w x y
) 'lamEntry1)
'(0 1) ;; w x '(0 1) ;; w x
) 'lamEntry2)
'(0)))) '(0)
'lamEntry3)))
(test (parse '(lambda (x) (test (parse '(lambda (x)
(lambda (y) (lambda (y)
@ -152,8 +157,10 @@
(make-Lam #f 1 (make-Lam #f 1
(make-Lam #f 1 (make-Lam #f 1
(make-LocalRef 0 #f) (make-LocalRef 0 #f)
'(0)) '(0)
(list)))) 'lamEntry1)
(list)
'lamEntry2)))
(test (parse '(lambda (x) (test (parse '(lambda (x)
(lambda (y) (lambda (y)
@ -162,8 +169,10 @@
(make-Lam #f 1 (make-Lam #f 1
(make-Lam #f 1 (make-Lam #f 1
(make-LocalRef 0 #f) (make-LocalRef 0 #f)
(list)) (list)
(list)))) 'lamEntry1)
(list)
'lamEntry2)))
(test (parse '(+ x x)) (test (parse '(+ x x))
(make-Top (make-Prefix '(+ x)) (make-Top (make-Prefix '(+ x))
@ -178,7 +187,8 @@
(make-App (make-ToplevelRef 2 0) (make-App (make-ToplevelRef 2 0)
(list (make-LocalRef 3 #f) (list (make-LocalRef 3 #f)
(make-LocalRef 3 #f))) (make-LocalRef 3 #f)))
'(0)))) '(0)
'lamEntry1)))
(test (parse '(lambda (x) (test (parse '(lambda (x)
(+ (* x x) x))) (+ (* x x) x)))
@ -192,7 +202,8 @@
(list (make-LocalRef 5 #f) (list (make-LocalRef 5 #f)
(make-LocalRef 5 #f))) (make-LocalRef 5 #f)))
(make-LocalRef 3 #f))) (make-LocalRef 3 #f)))
'(0)))) '(0)
'lamEntry1)))
(test (parse '(let () (test (parse '(let ()
x)) x))
@ -275,10 +286,10 @@
(make-Seq (make-Seq
(list (list
(make-InstallValue 0 (make-InstallValue 0
(make-Lam 'x 1 (make-LocalRef 0 #f) '()) (make-Lam 'x 1 (make-LocalRef 0 #f) '() 'lamEntry1)
#t) #t)
(make-InstallValue 1 (make-InstallValue 1
(make-Lam 'y 1 (make-LocalRef 0 #f) '()) (make-Lam 'y 1 (make-LocalRef 0 #f) '() 'lamEntry2)
#t) #t)
;; stack layout: ??? x y ;; stack layout: ??? x y
(make-App (make-LocalRef 1 #t) (make-App (make-LocalRef 1 #t)
@ -297,13 +308,15 @@
(make-Lam 'x 1 (make-Lam 'x 1
(make-App (make-LocalRef 1 #t) (make-App (make-LocalRef 1 #t)
(list (make-LocalRef 2 #f))) (list (make-LocalRef 2 #f)))
'(1)) '(1)
'lamEntry1)
#t) #t)
(make-InstallValue 1 (make-InstallValue 1
(make-Lam 'y 1 (make-Lam 'y 1
(make-App (make-LocalRef 2 #f) (make-App (make-LocalRef 2 #f)
(list (make-LocalRef 1 #t))) (list (make-LocalRef 1 #t)))
'(1)) '(1)
'lamEntry2)
#t) #t)
;; stack layout: ??? x y ;; stack layout: ??? x y
(make-App (make-LocalRef 1 #t) (make-App (make-LocalRef 1 #t)
@ -323,7 +336,8 @@
(list (make-LocalRef 2 #t))) (list (make-LocalRef 2 #t)))
#t) #t)
(make-Constant (void)))) (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))) (list (make-LocalRef 2 #t)))
#t) #t)
(make-Constant (void)))) (make-Constant (void))))
'(2 0)))) '(2 0)
'lamEntry1)))
#t))) #t)))
@ -374,6 +389,7 @@
(list (list
(make-Seq (list (make-ToplevelSet 0 0 'a (make-Constant '())) (make-Constant (void)))) (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)))))) (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 0 3) '())
(make-App (make-ToplevelRef 2 2) (list (make-ToplevelRef 2 0) (make-ToplevelRef 2 1))))))) (make-App (make-ToplevelRef 2 2) (list (make-ToplevelRef 2 0) (make-ToplevelRef 2 1)))))))