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)))
(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)))

3
expression-structs.rkt
View File

@ -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]

17
parse.rkt
View File

@ -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)

60
test-parse.rkt
View File

@ -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)))))))