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

Merge commit 'origin/master'

Browse Source
This commit is contained in:
Danny Yoo 2011-05-24 11:08:42 -04:00
commit 81a80b328f
4 changed files with 399 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
analyzer-structs.rkt Normal file
View File

@ -0,0 +1,35 @@
#lang typed/racket/base
(require "expression-structs.rkt"
"lexical-structs.rkt"
"kernel-primitives.rkt"
"il-structs.rkt")
(provide (all-defined-out))
;; Static knowledge about an expression.
;;
;; We try to keep at compile time a mapping from environment positions to
;; statically known things, to generate better code.
(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry))
(define-type CompileTimeEnvironmentEntry
(U '? ;; no knowledge
Prefix ;; placeholder: necessary since the toplevel lives in the environment too
StaticallyKnownLam ;; The value is a known lam
ModuleVariable ;; The value is a known module variable
Const
))
(define-struct: StaticallyKnownLam ([name : (U Symbol LamPositionalName)]
[entry-point : Symbol]
[arity : Arity]) #:transparent)

363
analyzer.rkt Normal file
View File

@ -0,0 +1,363 @@
#lang typed/racket/base
(provide (rename-out [-analyze analyze]))
(require "analyzer-structs.rkt"
"expression-structs.rkt"
"il-structs.rkt"
"lexical-structs.rkt"
racket/match
racket/list)
(: current-expression-map
(Parameterof (HashTable Expression CompileTimeEnvironmentEntry)))
(define current-expression-map (make-parameter
((inst make-hasheq Expression
CompileTimeEnvironmentEntry))))
(: -analyze (Expression -> (HashTable Expression CompileTimeEnvironmentEntry)))
(define (-analyze exp)
(parameterize ([current-expression-map
((inst make-hasheq Expression CompileTimeEnvironmentEntry))])
(analyze exp '())
(current-expression-map)))
(: analyze (Expression CompileTimeEnvironment -> 'ok))
;; Finds all the lambdas in the expression.
(define (analyze exp cenv)
(cond
[(Top? exp)
(analyze-Top exp cenv)]
[(Module? exp)
(analyze-Module exp cenv)]
[(Constant? exp)
(analyze-Constant exp cenv)]
[(LocalRef? exp)
(analyze-LocalRef exp cenv)]
[(ToplevelRef? exp)
(analyze-ToplevelRef exp cenv)]
[(ToplevelSet? exp)
(analyze-ToplevelSet exp cenv)]
[(Branch? exp)
(analyze-Branch exp cenv)]
[(Lam? exp)
(analyze-Lam exp cenv)]
[(CaseLam? exp)
(analyze-CaseLam exp cenv)]
[(EmptyClosureReference? exp)
(analyze-EmptyClosureReference exp cenv)]
[(Seq? exp)
(analyze-Seq exp cenv)]
[(Splice? exp)
(analyze-Splice exp cenv)]
[(Begin0? exp)
(analyze-Begin0 exp cenv)]
[(App? exp)
(analyze-App exp cenv)]
[(Let1? exp)
(analyze-Let1 exp cenv)]
[(LetVoid? exp)
(analyze-LetVoid exp cenv)]
[(InstallValue? exp)
(analyze-InstallValue exp cenv)]
[(BoxEnv? exp)
(analyze-BoxEnv exp cenv)]
[(LetRec? exp)
(analyze-LetRec exp cenv)]
[(WithContMark? exp)
(analyze-WithContMark exp cenv)]
[(ApplyValues? exp)
(analyze-ApplyValues exp cenv)]
[(DefValues? exp)
(analyze-DefValues exp cenv)]
[(PrimitiveKernelValue? exp)
(analyze-PrimitiveKernelValue exp cenv)]
[(VariableReference? exp)
(analyze-VariableReference exp cenv)]
[(Require? exp)
(analyze-Require exp cenv)]))
(: analyze-Top (Top CompileTimeEnvironment -> 'ok))
(define (analyze-Top exp cenv)
(match exp
[(struct Top (prefix code))
(analyze code (list prefix))]))
(: analyze-Module (Module CompileTimeEnvironment -> 'ok))
(define (analyze-Module exp cenv)
(match exp
[(struct Module (name path prefix requires code))
(analyze code (list prefix))]))
(: analyze-Constant (Constant CompileTimeEnvironment -> 'ok))
(define (analyze-Constant exp cenv)
'ok)
(: analyze-LocalRef (LocalRef CompileTimeEnvironment -> 'ok))
(define (analyze-LocalRef exp cenv)
(annotate exp (extract-static-knowledge exp cenv))
'ok)
(: analyze-ToplevelRef (ToplevelRef CompileTimeEnvironment -> 'ok))
(define (analyze-ToplevelRef exp cenv)
(annotate exp (extract-static-knowledge exp cenv))
'ok)
(: analyze-ToplevelSet (ToplevelSet CompileTimeEnvironment -> 'ok))
(define (analyze-ToplevelSet exp cenv)
(match exp
[(struct ToplevelSet (depth pos value))
(analyze value cenv)]))
(: analyze-Branch (Branch CompileTimeEnvironment -> 'ok))
(define (analyze-Branch exp cenv)
(match exp
[(struct Branch (test cons alter))
(analyze test cenv)
(analyze cons cenv)
(analyze alter cenv)]))
(: analyze-Lam (Lam CompileTimeEnvironment -> 'ok))
(define (analyze-Lam exp cenv)
(match exp
[(struct Lam (name num-parameters rest? body closure-map entry-label))
(analyze body (extract-lambda-body-cenv exp cenv))]))
(: extract-lambda-body-cenv (Lam CompileTimeEnvironment -> CompileTimeEnvironment))
;; Given a Lam and the ambient environment, produces the compile time environment for the
;; body of the lambda.
(define (extract-lambda-body-cenv lam cenv)
(append (map (lambda: ([d : Natural])
(list-ref cenv d))
(Lam-closure-map lam))
(build-list (if (Lam-rest? lam)
(add1 (Lam-num-parameters lam))
(Lam-num-parameters lam))
(lambda: ([i : Natural]) '?))))
(: analyze-CaseLam (CaseLam CompileTimeEnvironment -> 'ok))
(define (analyze-CaseLam exp cenv)
(match exp
[(struct CaseLam (name clauses entry-label))
(for-each (lambda: ([c : Expression])
(analyze c cenv))
clauses)
'ok]))
(: analyze-EmptyClosureReference (EmptyClosureReference CompileTimeEnvironment -> 'ok))
(define (analyze-EmptyClosureReference exp cenv)
'ok)
(: analyze-Seq (Seq CompileTimeEnvironment -> 'ok))
(define (analyze-Seq exp cenv)
(match exp
[(struct Seq (actions))
(for-each (lambda: ([e : Expression])
(analyze e cenv))
actions)
'ok]))
(: analyze-Splice (Splice CompileTimeEnvironment -> 'ok))
(define (analyze-Splice exp cenv)
(match exp
[(struct Splice (actions))
(for-each (lambda: ([e : Expression])
(analyze e cenv))
actions)
'ok]))
(: analyze-Begin0 (Begin0 CompileTimeEnvironment -> 'ok))
(define (analyze-Begin0 exp cenv)
(match exp
[(struct Begin0 (actions))
(for-each (lambda: ([e : Expression])
(analyze e cenv))
actions)
'ok]))
(: analyze-App (App CompileTimeEnvironment -> 'ok))
(define (analyze-App exp cenv)
(match exp
[(struct App (operator operands))
(let ([extended-cenv (extend/unknowns cenv (length operands))])
(analyze operator extended-cenv)
(for-each (lambda: ([o : Expression])
(analyze o extended-cenv))
operands)
'ok)]))
(: analyze-Let1 (Let1 CompileTimeEnvironment -> 'ok))
(define (analyze-Let1 exp cenv)
(match exp
[(struct Let1 (rhs body))
(analyze rhs
(extend/unknowns cenv 1))
(analyze body
(cons (extract-static-knowledge
rhs
(extend/unknowns cenv 1))
cenv))]))
(: analyze-LetVoid (LetVoid CompileTimeEnvironment -> 'ok))
(define (analyze-LetVoid exp cenv)
(match exp
[(struct LetVoid (count body boxes?))
(analyze body (extend/unknowns cenv count))]))
(: analyze-InstallValue (InstallValue CompileTimeEnvironment -> 'ok))
(define (analyze-InstallValue exp cenv)
(match exp
[(struct InstallValue (count depth body box?))
(analyze body cenv)]))
(: analyze-BoxEnv (BoxEnv CompileTimeEnvironment -> 'ok))
(define (analyze-BoxEnv exp cenv)
(match exp
[(struct BoxEnv (depth body))
(analyze body cenv)]))
(: analyze-LetRec (LetRec CompileTimeEnvironment -> 'ok))
(define (analyze-LetRec exp cenv)
(match exp
[(struct LetRec (procs body))
(let* ([n (length procs)]
[extended-cenv
(append (map (lambda: ([p : Expression])
(extract-static-knowledge p cenv))
procs)
(drop cenv n))])
(for-each (lambda: ([p : Expression])
(analyze p extended-cenv))
procs)
(analyze body extended-cenv))]))
(: analyze-WithContMark (WithContMark CompileTimeEnvironment -> 'ok))
(define (analyze-WithContMark exp cenv)
(match exp
[(struct WithContMark (key value body))
(analyze key cenv)
(analyze value cenv)
(analyze body cenv)]))
(: analyze-ApplyValues (ApplyValues CompileTimeEnvironment -> 'ok))
(define (analyze-ApplyValues exp cenv)
(match exp
[(struct ApplyValues (proc args-expr))
(analyze args-expr cenv)
(analyze proc cenv)]))
(: analyze-DefValues (DefValues CompileTimeEnvironment -> 'ok))
(define (analyze-DefValues exp cenv)
(match exp
[(struct DefValues (ids rhs))
(analyze rhs cenv)]))
(: analyze-PrimitiveKernelValue (PrimitiveKernelValue CompileTimeEnvironment -> 'ok))
(define (analyze-PrimitiveKernelValue exp cenv)
'ok)
(: analyze-VariableReference (VariableReference CompileTimeEnvironment -> 'ok))
(define (analyze-VariableReference exp cenv)
'ok)
(: analyze-Require (Require CompileTimeEnvironment -> 'ok))
(define (analyze-Require exp cenv)
'ok)
(: annotate (Expression CompileTimeEnvironmentEntry -> 'ok))
;; Accumulate information about an expression into the map.
(define (annotate exp info)
(let ([my-map (current-expression-map)])
(hash-set! my-map exp info)
'ok))
(: extend/unknowns
(CompileTimeEnvironment Natural -> CompileTimeEnvironment))
(define (extend/unknowns cenv n)
(append (build-list n (lambda: ([i : Natural])
'?))
cenv))
(: extract-static-knowledge (Expression CompileTimeEnvironment ->
CompileTimeEnvironmentEntry))
;; Statically determines what we know about the expression, given the compile time environment.
;; We should do more here eventually, including things like type inference or flow analysis, so that
;; we can generate better code.
(define (extract-static-knowledge exp cenv)
(cond
[(Lam? exp)
(make-StaticallyKnownLam (Lam-name exp)
(Lam-entry-label exp)
(if (Lam-rest? exp)
(make-ArityAtLeast (Lam-num-parameters exp))
(Lam-num-parameters exp)))]
[(and (LocalRef? exp) (not (LocalRef-unbox? exp)))
(let ([entry (list-ref cenv (LocalRef-depth exp))])
entry)]
[(ToplevelRef? exp)
(let: ([name : (U Symbol False GlobalBucket ModuleVariable)
(list-ref (Prefix-names
(ensure-prefix
(list-ref cenv (ToplevelRef-depth exp))))
(ToplevelRef-pos exp))])
(cond
[(ModuleVariable? name)
name]
[(GlobalBucket? name)
'?]
[else
'?]))]
[(Constant? exp)
(make-Const (Constant-v exp))]
[else
'?]))
(: ensure-prefix (Any -> Prefix))
(define (ensure-prefix x)
(if (Prefix? x)
x
(error 'ensure-prefix "Not a prefix: ~e" x)))

1
compiler.rkt
View File

@ -8,6 +8,7 @@
"optimize-il.rkt"
"parameters.rkt"
"sets.rkt"
"analyzer-structs.rkt"
racket/match
racket/bool
racket/list)

17
il-structs.rkt
View File

@ -475,23 +475,6 @@
;; Static knowledge about a value
;; We try to keep at compile time a mapping from environment positions to
;; statically known things, to generate better code.
(define-struct: StaticallyKnownLam ([name : (U Symbol LamPositionalName)]
[entry-point : Symbol]
[arity : Arity]) #:transparent)
(define-type CompileTimeEnvironmentEntry
(U '? ;; no knowledge
Prefix ;; placeholder: necessary since the toplevel lives in the environment too
StaticallyKnownLam ;; The value is a known lam
ModuleVariable ;; The value is a known module variable
Const
))
(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry))