diff --git a/analyzer.rkt b/analyzer.rkt index 6d54fd7..6075839 100644 --- a/analyzer.rkt +++ b/analyzer.rkt @@ -4,7 +4,10 @@ (require "analyzer-structs.rkt" "expression-structs.rkt" - racket/match) + "il-structs.rkt" + "lexical-structs.rkt" + racket/match + racket/list) @@ -90,39 +93,80 @@ (define (analyze-Top exp cenv) (match exp [(struct Top (prefix code)) - (analyze code (cons (Top-prefix exp) cenv))])) + (analyze code (list prefix))])) (: analyze-Module (Module CompileTimeEnvironment -> 'ok)) (define (analyze-Module exp cenv) - 'ok) + (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) - 'ok) + (match exp + [(struct ToplevelSet (depth pos value)) + (analyze value cenv)])) + (: analyze-Branch (Branch CompileTimeEnvironment -> 'ok)) (define (analyze-Branch exp cenv) - 'ok) + (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) - 'ok) + (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) - 'ok) + (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) @@ -130,51 +174,113 @@ (: analyze-Seq (Seq CompileTimeEnvironment -> 'ok)) (define (analyze-Seq exp cenv) - 'ok) + (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) - 'ok) + (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) - 'ok) + (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) - 'ok) + (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) - 'ok) + (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) - 'ok) + (match exp + [(struct LetVoid (count body boxes?)) + (analyze body (extend/unknowns cenv count))])) + (: analyze-InstallValue (InstallValue CompileTimeEnvironment -> 'ok)) (define (analyze-InstallValue exp cenv) - 'ok) + (match exp + [(struct InstallValue (count depth body box?)) + (analyze body cenv)])) + (: analyze-BoxEnv (BoxEnv CompileTimeEnvironment -> 'ok)) (define (analyze-BoxEnv exp cenv) - 'ok) + (match exp + [(struct BoxEnv (depth body)) + (analyze body cenv)])) + (: analyze-LetRec (LetRec CompileTimeEnvironment -> 'ok)) (define (analyze-LetRec exp cenv) - 'ok) + (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) - 'ok) + (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) - 'ok) + (match exp + [(struct ApplyValues (proc args-expr)) + (analyze args-expr cenv) + (analyze proc cenv)])) + (: analyze-DefValues (DefValues CompileTimeEnvironment -> 'ok)) (define (analyze-DefValues exp cenv) - 'ok) + (match exp + [(struct DefValues (ids rhs)) + (analyze rhs cenv)])) + (: analyze-PrimitiveKernelValue (PrimitiveKernelValue CompileTimeEnvironment -> 'ok)) (define (analyze-PrimitiveKernelValue exp cenv) @@ -199,3 +305,59 @@ '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))) \ No newline at end of file