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

trying to capture more static information

Browse Source
This commit is contained in:
Danny Yoo 2011-03-26 18:07:22 -04:00
parent befceb1751
commit 73962380ff
1 changed files with 47 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
compile.rkt
View File

@ -17,7 +17,9 @@
(define-struct: StaticallyKnownLam ([name : (U Symbol False)] (define-struct: StaticallyKnownLam ([name : (U Symbol False)]
[entry-point : Symbol] [entry-point : Symbol]
[arity : Natural]) #:transparent) [arity : Natural]) #:transparent)
(define-type CompileTimeEnvironmentEntry (U '? Prefix StaticallyKnownLam)) (define-type CompileTimeEnvironmentEntry (U '? Prefix StaticallyKnownLam))
(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry)) (define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry))
@ -393,27 +395,25 @@
extended-cenv extended-cenv
n n
target linkage)) target linkage))
(cond (let: ([static-knowledge : (U '? StaticallyKnownLam)
[(and (LocalRef? operator) (not (LocalRef-unbox? operator))) (extract-static-knowledge operator extended-cenv)])
(let: ([static-knowledge : CompileTimeEnvironmentEntry (list-ref extended-cenv (LocalRef-depth operator))]) (cond
(cond [(eq? static-knowledge '?)
[(eq? static-knowledge '?) (default)]
(default)] #;[(ModuleVariable? static-knowledge)
[(Prefix? static-knowledge) (default)]
(default)] [(StaticallyKnownLam? static-knowledge)
[(StaticallyKnownLam? static-knowledge) (unless (= n (StaticallyKnownLam-arity static-knowledge))
(unless (= n (StaticallyKnownLam-arity static-knowledge)) (error 'arity-mismatch "~s expected ~s arguments, but received ~s"
(error 'arity-mismatch "~s expected ~s arguments, but received ~s" (StaticallyKnownLam-name static-knowledge)
(StaticallyKnownLam-name static-knowledge) (StaticallyKnownLam-arity static-knowledge)
(StaticallyKnownLam-arity static-knowledge) n))
n)) (compile-procedure-call/statically-known-lam static-knowledge
(compile-procedure-call/statically-known-lam static-knowledge extended-cenv
extended-cenv n
n target
target linkage)])))
linkage)]))]
[else
(default)]))
(: juggle-operands ((Listof InstructionSequence) -> InstructionSequence)) (: juggle-operands ((Listof InstructionSequence) -> InstructionSequence))
;; Installs the operators. At the end of this, ;; Installs the operators. At the end of this,
@ -553,15 +553,32 @@
(error 'compile "return linkage, target not val: ~s" target)])) (error 'compile "return linkage, target not val: ~s" target)]))
(: extract-static-knowledge (ExpressionCore CompileTimeEnvironment -> CompileTimeEnvironmentEntry)) (: extract-static-knowledge (ExpressionCore CompileTimeEnvironment ->
(U StaticallyKnownLam '?)))
(define (extract-static-knowledge exp cenv) (define (extract-static-knowledge exp cenv)
(cond (cond
[(Lam? exp) [(Lam? exp)
(make-StaticallyKnownLam (Lam-name exp) (make-StaticallyKnownLam (Lam-name exp)
(Lam-entry-label exp) (Lam-entry-label exp)
(Lam-num-parameters exp))] (Lam-num-parameters exp))]
[(LocalRef? exp) [(and (LocalRef? exp)
(list-ref cenv (LocalRef-depth exp))] (not (LocalRef-unbox? exp)))
(let ([entry (list-ref cenv (LocalRef-depth exp))])
(cond
[(StaticallyKnownLam? entry)
entry]
[else
'?]))]
[(ToplevelRef? exp)
(let: ([name : (U Symbol False ModuleVariable)
(list-ref (Prefix-names (ensure-prefix (list-ref cenv (ToplevelRef-depth exp))))
(ToplevelRef-pos exp))])
(cond
[(ModuleVariable? name)
;; fixme
'?]
[else
'?]))]
[else [else
'?])) '?]))
@ -729,6 +746,12 @@
n n
(error 'ensure-natural "Not a natural: ~s\n" n))) (error 'ensure-natural "Not a natural: ~s\n" n)))
(: ensure-prefix (CompileTimeEnvironmentEntry -> Prefix))
(define (ensure-prefix x)
(if (Prefix? x)
x
(error 'ensure-prefix "Not a prefix: ~s" x)))
(: adjust-target-depth (Target Natural -> Target)) (: adjust-target-depth (Target Natural -> Target))