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

need to do a little more work.

Browse Source
This commit is contained in:
Danny Yoo 2011-03-23 21:57:07 -04:00
parent 15a03bba7c
commit f6aceb9d52
2 changed files with 64 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
bootstrapped-primitives.rkt
View File

@ -46,11 +46,11 @@
,(make-PopEnvironment 2 0))) ,(make-PopEnvironment 2 0)))
;; Finally, do a tail call into f. ;; Finally, do a tail call into f.
(compile-procedure-call '() (compile-general-procedure-call '()
'(?) '(?)
1 1
'val 'val
'return) 'return)
;; The code for the continuation coe follows. It's supposed to ;; The code for the continuation coe follows. It's supposed to
;; abandon the current continuation, initialize the control and environment, and then jump. ;; abandon the current continuation, initialize the control and environment, and then jump.

104
compile.rkt
View File

@ -6,7 +6,7 @@
racket/list) racket/list)
(provide (rename-out [-compile compile]) (provide (rename-out [-compile compile])
compile-procedure-call compile-general-procedure-call
append-instruction-sequences append-instruction-sequences
adjust-target-depth) adjust-target-depth)
@ -259,50 +259,64 @@
;; 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* ([extended-cenv (append (map (lambda: ([op : ExpressionCore]) (let* ([extended-cenv (append (map (lambda: ([op : ExpressionCore])
'?) '?)
(App-operands exp)) (App-operands exp))
cenv)] cenv)]
[proc-code (compile (App-operator exp) [proc-code (compile (App-operator exp)
extended-cenv extended-cenv
(if (empty? (App-operands exp)) (if (empty? (App-operands exp))
'proc 'proc
(make-EnvLexicalReference (make-EnvLexicalReference
(ensure-natural (sub1 (length (App-operands exp)))) (ensure-natural (sub1 (length (App-operands exp))))
#f)) #f))
'next)] 'next)]
[operand-codes (map (lambda: ([operand : Expression] [operand-codes (map (lambda: ([operand : Expression]
[target : Target]) [target : Target])
(compile operand extended-cenv target 'next)) (compile operand extended-cenv target 'next))
(App-operands exp) (App-operands exp)
(build-list (length (App-operands exp)) (build-list (length (App-operands exp))
(lambda: ([i : Natural]) (lambda: ([i : Natural])
(if (< i (sub1 (length (App-operands exp)))) (if (< i (sub1 (length (App-operands exp))))
(make-EnvLexicalReference i #f) (make-EnvLexicalReference i #f)
'val))))]) 'val))))])
(append-instruction-sequences (append-instruction-sequences
(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 (App-operator exp) cenv extended-cenv (length (App-operands exp))
(let: ([operator : ExpressionCore (App-operator exp)]) target linkage))))
(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)])))))
(: compile-procedure-call
(ExpressionCore CompileTimeEnvironment CompileTimeEnvironment Natural Target Linkage -> InstructionSequence))
(define (compile-procedure-call operator cenv-before-args extended-cenv n target linkage)
(define (default)
(compile-general-procedure-call cenv-before-args
extended-cenv
n
target linkage))
(cond
[(and (LocalRef? operator) (not (LocalRef-unbox? operator)))
(let: ([static-knowledge : CompileTimeEnvironmentEntry (list-ref extended-cenv (LocalRef-depth operator))])
(cond
[(eq? static-knowledge 'prefix)
(default)]
[(eq? static-knowledge '?)
(default)]
[(StaticallyKnownLam? static-knowledge)
(unless (= n (StaticallyKnownLam-arity static-knowledge))
(error 'arity-mismatch "Expected ~s, received ~s" (StaticallyKnownLam-arity static-knowledge)
n))
;; FIXME: do the arity check here...
#;(printf "I'm here!\n")
(compile-procedure-call/statically-known-lam extended-cenv
n
target
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,
@ -332,7 +346,7 @@
(: compile-procedure-call (CompileTimeEnvironment CompileTimeEnvironment (: compile-general-procedure-call (CompileTimeEnvironment CompileTimeEnvironment
Natural Target Linkage Natural Target Linkage
-> ->
InstructionSequence)) InstructionSequence))
@ -340,7 +354,7 @@
;; n is the number of arguments passed in. ;; n is the number of arguments passed in.
;; cenv is the compile-time enviroment before arguments have been shifted in. ;; cenv is the compile-time enviroment before arguments have been shifted in.
;; extended-cenv is the compile-time environment after arguments have been shifted in. ;; extended-cenv is the compile-time environment after arguments have been shifted in.
(define (compile-procedure-call cenv extended-cenv n target linkage) (define (compile-general-procedure-call cenv extended-cenv n target linkage)
(let ([primitive-branch (make-label 'primitiveBranch)] (let ([primitive-branch (make-label 'primitiveBranch)]
[compiled-branch (make-label 'compiledBranch)] [compiled-branch (make-label 'compiledBranch)]
[after-call (make-label 'afterCall)]) [after-call (make-label 'afterCall)])