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

continuing to remove explicit calls to make-instruction-sequence

Browse Source
This commit is contained in:
Danny Yoo 2011-08-07 17:24:53 -04:00
parent 356901cf7e
commit 0757040ec2
1 changed files with 92 additions and 112 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

204
compiler/compiler.rkt
View File

@ -43,24 +43,20 @@
(append-instruction-sequences (append-instruction-sequences
;; Layout the lambda bodies... ;; Layout the lambda bodies...
(make-instruction-sequence (make-GotoStatement (make-Label after-lam-bodies))
`(,(make-GotoStatement (make-Label after-lam-bodies))))
(compile-lambda-bodies (collect-all-lambdas-with-bodies exp)) (compile-lambda-bodies (collect-all-lambdas-with-bodies exp))
after-lam-bodies after-lam-bodies
;; Begin a prompted evaluation: ;; Begin a prompted evaluation:
(make-instruction-sequence (make-PushControlFrame/Prompt default-continuation-prompt-tag
`(,(make-PushControlFrame/Prompt default-continuation-prompt-tag before-pop-prompt)
before-pop-prompt)))
(compile exp '() 'val return-linkage/nontail) (compile exp '() 'val return-linkage/nontail)
before-pop-prompt-multiple before-pop-prompt-multiple
(make-instruction-sequence (make-PopEnvironment (make-Reg 'argcount) (make-Const 0))
`(,(make-PopEnvironment (make-Reg 'argcount) (make-Const 0))))
before-pop-prompt before-pop-prompt
(if (eq? target 'val) (if (eq? target 'val)
empty-instruction-sequence empty-instruction-sequence
(make-instruction-sequence (make-AssignImmediateStatement target (make-Reg 'val)))))))))
`(,(make-AssignImmediateStatement target (make-Reg 'val)))))))))))
(define-struct: lam+cenv ([lam : (U Lam CaseLam)] (define-struct: lam+cenv ([lam : (U Lam CaseLam)]
@ -199,25 +195,24 @@
[(ReturnLinkage-tail? linkage) [(ReturnLinkage-tail? linkage)
;; Under tail calls, clear the environment of the current stack frame (represented by cenv) ;; Under tail calls, clear the environment of the current stack frame (represented by cenv)
;; and do the jump. ;; and do the jump.
(make-instruction-sequence (append-instruction-sequences
`(,(make-PopEnvironment (make-Const (length cenv)) (make-PopEnvironment (make-Const (length cenv))
(make-Const 0)) (make-Const 0))
,(make-AssignImmediateStatement 'proc (make-ControlStackLabel)) (make-AssignImmediateStatement 'proc (make-ControlStackLabel))
,(make-PopControlFrame) (make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))))] (make-GotoStatement (make-Reg 'proc)))]
[else [else
;; Under non-tail calls, leave the stack as is and just do the jump. ;; Under non-tail calls, leave the stack as is and just do the jump.
(make-instruction-sequence (append-instruction-sequences
`(,(make-AssignImmediateStatement 'proc (make-ControlStackLabel)) (make-AssignImmediateStatement 'proc (make-ControlStackLabel))
,(make-PopControlFrame) (make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))))])] (make-GotoStatement (make-Reg 'proc)))])]
[(NextLinkage? linkage) [(NextLinkage? linkage)
empty-instruction-sequence] empty-instruction-sequence]
[(LabelLinkage? linkage) [(LabelLinkage? linkage)
(make-instruction-sequence (make-GotoStatement (make-Label (LabelLinkage-label linkage)))]))
`(,(make-GotoStatement (make-Label (LabelLinkage-label linkage)))))]))
@ -300,16 +295,14 @@
(end-with-linkage (end-with-linkage
linkage cenv linkage cenv
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence (make-PerformStatement (make-ExtendEnvironment/Prefix! names))
`(,(make-PerformStatement (make-ExtendEnvironment/Prefix! names))))
(compile (Top-code top) (compile (Top-code top)
(cons (Top-prefix top) cenv) (cons (Top-prefix top) cenv)
'val 'val
next-linkage/drop-multiple) next-linkage/drop-multiple)
(make-instruction-sequence (make-AssignImmediateStatement target (make-Reg 'val))
`(,(make-AssignImmediateStatement target (make-Reg 'val)) (make-PopEnvironment (make-Const 1)
,(make-PopEnvironment (make-Const 1) (make-Const 0))))))
(make-Const 0))))))))
@ -371,8 +364,7 @@
(end-with-linkage linkage cenv (end-with-linkage linkage cenv
(append-instruction-sequences (append-instruction-sequences
(compile-module-invoke (Require-path exp)) (compile-module-invoke (Require-path exp))
(make-instruction-sequence (make-AssignImmediateStatement target (make-Const (void))))))
`(,(make-AssignImmediateStatement target (make-Const (void))))))))
(: compile-module-invoke (ModuleLocator -> InstructionSequence)) (: compile-module-invoke (ModuleLocator -> InstructionSequence))
@ -381,36 +373,36 @@
;; if the module hasn't been linked yet. ;; if the module hasn't been linked yet.
(define (compile-module-invoke a-module-name) (define (compile-module-invoke a-module-name)
(cond (cond
[(kernel-module-name? a-module-name) [(kernel-module-name? a-module-name)
empty-instruction-sequence] empty-instruction-sequence]
[else [else
(let* ([linked (make-label 'linked)] (let* ([linked (make-label 'linked)]
[already-loaded (make-label 'alreadyLoaded)] [already-loaded (make-label 'alreadyLoaded)]
[on-return-multiple (make-label 'onReturnMultiple)] [on-return-multiple (make-label 'onReturnMultiple)]
[on-return (make-LinkedLabel (make-label 'onReturn) [on-return (make-LinkedLabel (make-label 'onReturn)
on-return-multiple)]) on-return-multiple)])
(make-instruction-sequence (append-instruction-sequences
`(,(make-TestAndJumpStatement (make-TestTrue (make-TestAndJumpStatement (make-TestTrue
(make-IsModuleLinked a-module-name)) (make-IsModuleLinked a-module-name))
linked) linked)
;; TODO: raise an exception here that says that the module hasn't been ;; TODO: raise an exception here that says that the module hasn't been
;; linked yet. ;; linked yet.
,(make-DebugPrint (make-Const (make-DebugPrint (make-Const
(format "DEBUG: the module ~a hasn't been linked in!!!" (format "DEBUG: the module ~a hasn't been linked in!!!"
(ModuleLocator-name a-module-name)))) (ModuleLocator-name a-module-name))))
,(make-GotoStatement (make-Label already-loaded)) (make-GotoStatement (make-Label already-loaded))
,linked linked
,(make-TestAndJumpStatement (make-TestTrue (make-TestAndJumpStatement (make-TestTrue
(make-IsModuleInvoked a-module-name)) (make-IsModuleInvoked a-module-name))
already-loaded) already-loaded)
,(make-PushControlFrame/Call on-return) (make-PushControlFrame/Call on-return)
,(make-GotoStatement (ModuleEntry a-module-name)) (make-GotoStatement (ModuleEntry a-module-name))
,on-return-multiple on-return-multiple
,(make-PopEnvironment (make-SubtractArg (make-Reg 'argcount) (make-PopEnvironment (make-SubtractArg (make-Reg 'argcount)
(make-Const 1)) (make-Const 1))
(make-Const 0)) (make-Const 0))
,on-return on-return
,already-loaded)))])) already-loaded))]))
(: kernel-module-name? (ModuleLocator -> Boolean)) (: kernel-module-name? (ModuleLocator -> Boolean))
@ -445,18 +437,15 @@
empty-instruction-sequence] empty-instruction-sequence]
[(eq? context 'keep-multiple) [(eq? context 'keep-multiple)
(make-instruction-sequence (make-AssignImmediateStatement 'argcount (make-Const 1))]
`(,(make-AssignImmediateStatement 'argcount (make-Const 1))))]
[(natural? context) [(natural? context)
(if (= context 1) (if (= context 1)
empty-instruction-sequence empty-instruction-sequence
(make-instruction-sequence (append-instruction-sequences
`(,(make-AssignImmediateStatement 'argcount (make-AssignImmediateStatement 'argcount (make-Const 1))
(make-Const 1)) (make-PerformStatement (make-RaiseContextExpectedValuesError!
,(make-PerformStatement context))))]))]))
(make-RaiseContextExpectedValuesError!
context)))))]))]))
@ -468,8 +457,7 @@
(end-with-linkage linkage (end-with-linkage linkage
cenv cenv
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence (make-AssignImmediateStatement target (make-Const (Constant-v exp)))
`(,(make-AssignImmediateStatement target (make-Const (Constant-v exp)))))
singular-context-check)))) singular-context-check))))
@ -480,8 +468,7 @@
(end-with-linkage linkage (end-with-linkage linkage
cenv cenv
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence (make-AssignImmediateStatement target exp)
`(,(make-AssignImmediateStatement target exp)))
singular-context-check)))) singular-context-check))))
@ -492,11 +479,9 @@
(end-with-linkage linkage (end-with-linkage linkage
cenv cenv
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence (make-AssignImmediateStatement target
`(,(make-AssignImmediateStatement (make-EnvLexicalReference (LocalRef-depth exp)
target (LocalRef-unbox? exp)))
(make-EnvLexicalReference (LocalRef-depth exp)
(LocalRef-unbox? exp)))))
singular-context-check)))) singular-context-check))))
@ -677,25 +662,24 @@
[(ReturnLinkage? linkage) [(ReturnLinkage? linkage)
(cond (cond
[(ReturnLinkage-tail? linkage) [(ReturnLinkage-tail? linkage)
(make-instruction-sequence (append-instruction-sequences
`(,(make-PopEnvironment (make-Const (length cenv)) (make-PopEnvironment (make-Const (length cenv))
(make-SubtractArg (make-Reg 'argcount) (make-SubtractArg (make-Reg 'argcount)
(make-Const 1))) (make-Const 1)))
,(make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn)) (make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn))
,(make-PopControlFrame) (make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))))] (make-GotoStatement (make-Reg 'proc)))]
[else [else
(make-instruction-sequence (append-instruction-sequences
`(,(make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn)) (make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn))
,(make-PopControlFrame) (make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))))])] (make-GotoStatement (make-Reg 'proc)))])]
[(NextLinkage? linkage) [(NextLinkage? linkage)
empty-instruction-sequence] empty-instruction-sequence]
[(LabelLinkage? linkage) [(LabelLinkage? linkage)
(make-instruction-sequence (make-GotoStatement (make-Label (LabelLinkage-label linkage)))])))]))
`(,(make-GotoStatement (make-Label (LabelLinkage-label linkage)))))])))]))
@ -757,8 +741,7 @@
(apply append-instruction-sequences (apply append-instruction-sequences
(map (lambda: ([lam : (U Lam EmptyClosureReference)] (map (lambda: ([lam : (U Lam EmptyClosureReference)]
[target : Target]) [target : Target])
(make-instruction-sequence (make-AssignPrimOpStatement
`(,(make-AssignPrimOpStatement
target target
(cond (cond
[(Lam? lam) [(Lam? lam)
@ -770,7 +753,7 @@
(make-MakeCompiledProcedure (EmptyClosureReference-entry-label lam) (make-MakeCompiledProcedure (EmptyClosureReference-entry-label lam)
(EmptyClosureReference-arity lam) (EmptyClosureReference-arity lam)
'() '()
(EmptyClosureReference-name lam))]))))) (EmptyClosureReference-name lam))])))
(CaseLam-clauses exp) (CaseLam-clauses exp)
(build-list (length (CaseLam-clauses exp)) (build-list (length (CaseLam-clauses exp))
(lambda: ([i : Natural]) (lambda: ([i : Natural])
@ -863,18 +846,17 @@
(define (compile-lambda-body exp cenv) (define (compile-lambda-body exp cenv)
(let: ([maybe-unsplice-rest-argument : InstructionSequence (let: ([maybe-unsplice-rest-argument : InstructionSequence
(if (Lam-rest? exp) (if (Lam-rest? exp)
(make-instruction-sequence (make-PerformStatement
`(,(make-PerformStatement
(make-UnspliceRestFromStack! (make-UnspliceRestFromStack!
(make-Const (Lam-num-parameters exp)) (make-Const (Lam-num-parameters exp))
(make-SubtractArg (make-Reg 'argcount) (make-SubtractArg (make-Reg 'argcount)
(make-Const (Lam-num-parameters exp))))))) (make-Const (Lam-num-parameters exp)))))
empty-instruction-sequence)] empty-instruction-sequence)]
[maybe-install-closure-values : InstructionSequence [maybe-install-closure-values : InstructionSequence
(if (not (empty? (Lam-closure-map exp))) (if (not (empty? (Lam-closure-map exp)))
(make-instruction-sequence (append-instruction-sequences
`(,(make-Comment (format "installing closure for ~s" (Lam-name exp))) (make-Comment (format "installing closure for ~s" (Lam-name exp)))
,(make-PerformStatement (make-InstallClosureValues!)))) (make-PerformStatement (make-InstallClosureValues!)))
empty-instruction-sequence)] empty-instruction-sequence)]
[lam-body-code : InstructionSequence [lam-body-code : InstructionSequence
(compile (Lam-body exp) (compile (Lam-body exp)
@ -1000,10 +982,10 @@
[(Prefix? op-knowledge) [(Prefix? op-knowledge)
(error 'impossible)] (error 'impossible)]
[(Const? op-knowledge) [(Const? op-knowledge)
(make-instruction-sequence (append-instruction-sequences
`(,(make-AssignImmediateStatement 'proc op-knowledge) (make-AssignImmediateStatement 'proc op-knowledge)
,(make-PerformStatement (make-PerformStatement
(make-RaiseOperatorApplicationError! (make-Reg 'proc)))))])))) (make-RaiseOperatorApplicationError! (make-Reg 'proc))))]))))
(: compile-general-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-general-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence))
@ -1832,11 +1814,10 @@
(apply append-instruction-sequences (apply append-instruction-sequences
(map (lambda: ([lam : Lam] (map (lambda: ([lam : Lam]
[i : Natural]) [i : Natural])
(make-instruction-sequence (append-instruction-sequences
`(,(make-Comment (format "Installing shell for ~s\n" (Lam-name lam))) (make-Comment (format "Installing shell for ~s\n" (Lam-name lam)))
,(make-PerformStatement (make-PerformStatement (make-FixClosureShellMap! i
(make-FixClosureShellMap! i (Lam-closure-map lam)))))) (Lam-closure-map lam)))))
(LetRec-procs exp) (LetRec-procs exp)
(build-list n (lambda: ([i : Natural]) i)))) (build-list n (lambda: ([i : Natural]) i))))
@ -1884,9 +1865,9 @@
(apply append-instruction-sequences (apply append-instruction-sequences
(map (lambda: ([to : EnvLexicalReference] (map (lambda: ([to : EnvLexicalReference]
[from : OpArg]) [from : OpArg])
(make-instruction-sequence (append-instruction-sequences
`(,(make-Comment "install-value: installing value") (make-Comment "install-value: installing value")
,(make-AssignImmediateStatement to from)))) (make-AssignImmediateStatement to from)))
(build-list count (lambda: ([i : Natural]) (build-list count (lambda: ([i : Natural])
(make-EnvLexicalReference (+ i (make-EnvLexicalReference (+ i
(InstallValue-depth exp) (InstallValue-depth exp)
@ -2014,15 +1995,14 @@
(apply append-instruction-sequences (apply append-instruction-sequences
(map (lambda: ([id : ToplevelRef] (map (lambda: ([id : ToplevelRef]
[from : OpArg]) [from : OpArg])
(make-instruction-sequence (make-AssignImmediateStatement
`(,(make-AssignImmediateStatement
;; Slightly subtle: the toplevelrefs were with respect to the ;; Slightly subtle: the toplevelrefs were with respect to the
;; stack at the beginning of def-values, but at the moment, ;; stack at the beginning of def-values, but at the moment,
;; there may be additional values that are currently there. ;; there may be additional values that are currently there.
(make-EnvPrefixReference (+ (ensure-natural (sub1 n)) (make-EnvPrefixReference (+ (ensure-natural (sub1 n))
(ToplevelRef-depth id)) (ToplevelRef-depth id))
(ToplevelRef-pos id)) (ToplevelRef-pos id))
from)))) from))
ids ids
(if (> n 0) (if (> n 0)
(cons (make-Reg 'val) (cons (make-Reg 'val)