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

making compiledprocedurenetry an oparg

Browse Source 
making compiledprocedurenetry an oparg
This commit is contained in:
Danny Yoo 2011-04-25 14:38:57 -04:00
parent 876d3bb8e2
commit b27f925dd4
6 changed files with 92 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
assemble-helpers.rkt
View File

@ -41,7 +41,9 @@
[(ControlStackLabel? v) [(ControlStackLabel? v)
(assemble-control-stack-label v)] (assemble-control-stack-label v)]
[(ControlStackLabel/MultipleValueReturn? v) [(ControlStackLabel/MultipleValueReturn? v)
(assemble-control-stack-label/multiple-value-return v)])) (assemble-control-stack-label/multiple-value-return v)]
[(CompiledProcedureEntry? v)
(assemble-compiled-procedure-entry v)]))
@ -148,6 +150,12 @@
(: assemble-compiled-procedure-entry (CompiledProcedureEntry -> String))
(define (assemble-compiled-procedure-entry a-compiled-procedure-entry)
(format "(~a).label"
(assemble-oparg (CompiledProcedureEntry-proc a-compiled-procedure-entry))))
(: assemble-default-continuation-prompt-tag (-> String)) (: assemble-default-continuation-prompt-tag (-> String))
(define (assemble-default-continuation-prompt-tag) (define (assemble-default-continuation-prompt-tag)
@ -191,9 +199,9 @@
(: assemble-jump ((U Label Reg) -> String)) (: assemble-jump (OpArg -> String))
(define (assemble-jump target) (define (assemble-jump target)
(format "return (~a)(MACHINE);" (assemble-location target))) (format "return (~a)(MACHINE);" (assemble-oparg target)))

6
collect-jump-targets.rkt
View File

@ -43,7 +43,7 @@
[(TestAndBranchStatement? stmt) [(TestAndBranchStatement? stmt)
(list (TestAndBranchStatement-label stmt))] (list (TestAndBranchStatement-label stmt))]
[(GotoStatement? stmt) [(GotoStatement? stmt)
(collect-location (GotoStatement-target stmt))] (collect-input (GotoStatement-target stmt))]
[(PushEnvironment? stmt) [(PushEnvironment? stmt)
empty] empty]
[(PopEnvironment? stmt) [(PopEnvironment? stmt)
@ -82,7 +82,9 @@
[(ControlStackLabel? an-input) [(ControlStackLabel? an-input)
empty] empty]
[(ControlStackLabel/MultipleValueReturn? an-input) [(ControlStackLabel/MultipleValueReturn? an-input)
empty])) empty]
[(CompiledProcedureEntry? an-input)
(collect-input (CompiledProcedureEntry-proc an-input))]))
(: collect-location ((U Reg Label) -> (Listof Symbol))) (: collect-location ((U Reg Label) -> (Listof Symbol)))
(define (collect-location a-location) (define (collect-location a-location)

76
compiler.rkt
View File

@ -234,14 +234,15 @@
`(,(make-GotoStatement (make-Label (LabelLinkage-label linkage)))))])) `(,(make-GotoStatement (make-Label (LabelLinkage-label linkage)))))]))
(: compile-singular-context-check (Linkage -> InstructionSequence)) (: emit-singular-context-check (Linkage -> InstructionSequence))
;; Emits code to raise a runtime error if the linkage requires ;; Emits code to raise a runtime error if the linkage requires
;; multiple values will be produced. ;; multiple values will be produced, since there's no way to produce them.
(define (compile-singular-context-check linkage) (define (emit-singular-context-check linkage)
(cond [(ReturnLinkage? linkage) (cond [(ReturnLinkage? linkage)
empty-instruction-sequence] empty-instruction-sequence]
[(NextLinkage? linkage) [(or (NextLinkage? linkage)
(let ([context (NextLinkage-context linkage)]) (LabelLinkage? linkage))
(let ([context (linkage-context linkage)])
(cond (cond
[(eq? context 'drop-multiple) [(eq? context 'drop-multiple)
empty-instruction-sequence] empty-instruction-sequence]
@ -252,28 +253,12 @@
empty-instruction-sequence empty-instruction-sequence
(make-instruction-sequence (make-instruction-sequence
`(,(make-PerformStatement `(,(make-PerformStatement
(make-RaiseContextExpectedValuesError! 1)))))]))] (make-RaiseContextExpectedValuesError! 1)))))]))]))
[(LabelLinkage? linkage)
(let ([context (LabelLinkage-context linkage)])
(cond
[(eq? context 'drop-multiple)
empty-instruction-sequence]
[else
(let ([n context])
(cond
[(eq? n 'keep-multiple)
empty-instruction-sequence]
[(natural? n)
(if (= n 1)
empty-instruction-sequence
(make-instruction-sequence
`(,(make-PerformStatement
(make-RaiseContextExpectedValuesError! 1)))))]))]))]))
(: compile-constant (Constant CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-constant (Constant CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-constant exp cenv target linkage) (define (compile-constant exp cenv target linkage)
(let ([singular-context-check (compile-singular-context-check linkage)]) (let ([singular-context-check (emit-singular-context-check linkage)])
;; Compiles constant values. ;; Compiles constant values.
(end-with-linkage linkage (end-with-linkage linkage
cenv cenv
@ -286,7 +271,7 @@
(: compile-local-reference (LocalRef CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-local-reference (LocalRef CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-local-reference exp cenv target linkage) (define (compile-local-reference exp cenv target linkage)
(let ([singular-context-check (compile-singular-context-check linkage)]) (let ([singular-context-check (emit-singular-context-check linkage)])
(end-with-linkage linkage (end-with-linkage linkage
cenv cenv
(append-instruction-sequences (append-instruction-sequences
@ -301,7 +286,7 @@
(: compile-toplevel-reference (ToplevelRef CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-toplevel-reference (ToplevelRef CompileTimeEnvironment Target Linkage -> InstructionSequence))
;; Compiles toplevel references. ;; Compiles toplevel references.
(define (compile-toplevel-reference exp cenv target linkage) (define (compile-toplevel-reference exp cenv target linkage)
(let ([singular-context-check (compile-singular-context-check linkage)]) (let ([singular-context-check (emit-singular-context-check linkage)])
(end-with-linkage linkage (end-with-linkage linkage
cenv cenv
(append-instruction-sequences (append-instruction-sequences
@ -325,7 +310,7 @@
(let ([get-value-code (let ([get-value-code
(compile (ToplevelSet-value exp) cenv lexical-pos (compile (ToplevelSet-value exp) cenv lexical-pos
next-linkage/expects-single)] next-linkage/expects-single)]
[singular-context-check (compile-singular-context-check linkage)]) [singular-context-check (emit-singular-context-check linkage)])
(end-with-linkage (end-with-linkage
linkage linkage
cenv cenv
@ -354,7 +339,8 @@
(let ([p-code (compile (Branch-predicate exp) cenv 'val next-linkage/expects-single)] (let ([p-code (compile (Branch-predicate exp) cenv 'val next-linkage/expects-single)]
[c-code (compile (Branch-consequent exp) cenv target consequent-linkage)] [c-code (compile (Branch-consequent exp) cenv target consequent-linkage)]
[a-code (compile (Branch-alternative exp) cenv target linkage)]) [a-code (compile (Branch-alternative exp) cenv target linkage)])
(append-instruction-sequences p-code (append-instruction-sequences
p-code
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence (make-instruction-sequence
`(,(make-TestAndBranchStatement 'false? `(,(make-TestAndBranchStatement 'false?
@ -422,7 +408,7 @@
;; The lambda will close over the free variables. ;; The lambda will close over the free variables.
;; Assumption: all of the lambda bodies have already been written out at the top, in -compile. ;; Assumption: all of the lambda bodies have already been written out at the top, in -compile.
(define (compile-lambda exp cenv target linkage) (define (compile-lambda exp cenv target linkage)
(let ([singular-context-check (compile-singular-context-check linkage)]) (let ([singular-context-check (emit-singular-context-check linkage)])
(end-with-linkage (end-with-linkage
linkage linkage
cenv cenv
@ -443,7 +429,7 @@
;; Write out code for lambda expressions, minus the closure map. ;; Write out code for lambda expressions, minus the closure map.
;; Assumption: all of the lambda bodies have already been written out at the top, in -compile. ;; Assumption: all of the lambda bodies have already been written out at the top, in -compile.
(define (compile-lambda-shell exp cenv target linkage) (define (compile-lambda-shell exp cenv target linkage)
(let ([singular-context-check (compile-singular-context-check linkage)]) (let ([singular-context-check (emit-singular-context-check linkage)])
(end-with-linkage (end-with-linkage
linkage linkage
cenv cenv
@ -552,12 +538,12 @@
[(Prefix? op-knowledge) [(Prefix? op-knowledge)
(error 'impossible)] (error 'impossible)]
[(Const? op-knowledge) [(Const? op-knowledge)
(make-instruction-sequence `(,(make-AssignImmediateStatement 'proc op-knowledge) (make-instruction-sequence
`(,(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))
(define (compile-general-application exp cenv target linkage) (define (compile-general-application exp cenv target linkage)
(let* ([extended-cenv (let* ([extended-cenv
@ -981,7 +967,7 @@
(make-instruction-sequence (make-instruction-sequence
`(,(make-PerformStatement (make-CheckClosureArity! (make-Reg 'argcount))))) `(,(make-PerformStatement (make-CheckClosureArity! (make-Reg 'argcount)))))
(compile-compiled-procedure-application extended-cenv-length (compile-compiled-procedure-application extended-cenv-length
'val 'dynamic
target target
compiled-linkage) compiled-linkage)
@ -1035,7 +1021,7 @@
(: compile-compiled-procedure-application (OpArg (U Label 'val) Target Linkage -> InstructionSequence)) (: compile-compiled-procedure-application (OpArg (U Label 'dynamic) Target Linkage -> InstructionSequence))
;; This is the heart of compiled procedure application. A lot of things happen here. ;; This is the heart of compiled procedure application. A lot of things happen here.
;; ;;
;; Procedure linkage. ;; Procedure linkage.
@ -1047,18 +1033,16 @@
;; 2. Non-tail calls (next/label linkage) that write to val ;; 2. Non-tail calls (next/label linkage) that write to val
;; 3. Calls in argument position (next/label linkage) that write to the stack. ;; 3. Calls in argument position (next/label linkage) that write to the stack.
(define (compile-compiled-procedure-application cenv-length-with-args entry-point target linkage) (define (compile-compiled-procedure-application cenv-length-with-args entry-point target linkage)
(let*-values ([(maybe-install-jump-address entry-point-target) (let* ([entry-point-target
;; Optimization: if the entry-point is supposed to be val, then it needs to hold ;; Optimization: if the entry-point is known to be a static label,
;; the procedure entry here. Otherwise, it doesn't. ;; use that. Otherwise, grab the entry point from the proc register.
(cond [(Label? entry-point) (cond [(Label? entry-point)
(values empty-instruction-sequence entry-point)] entry-point]
[(eq? entry-point 'val) [(eq? entry-point 'dynamic)
(values (make-instruction-sequence (make-CompiledProcedureEntry (make-Reg 'proc))])]
`(,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))))
(make-Reg 'val))])]
;; If the target isn't val, migrate the value from val into it. ;; If the target isn't val, migrate the value from val into it.
[(maybe-migrate-val-to-target) [maybe-migrate-val-to-target
(cond (cond
[(eq? target 'val) [(eq? target 'val)
empty-instruction-sequence] empty-instruction-sequence]
@ -1066,16 +1050,15 @@
(make-instruction-sequence (make-instruction-sequence
`(,(make-AssignImmediateStatement target (make-Reg 'val))))])] `(,(make-AssignImmediateStatement target (make-Reg 'val))))])]
[(proc-return-multiple) (make-label 'procReturnMultiple)] [proc-return-multiple (make-label 'procReturnMultiple)]
[(proc-return) (make-LinkedLabel (make-label 'procReturn) [proc-return (make-LinkedLabel (make-label 'procReturn)
proc-return-multiple)] proc-return-multiple)]
;; This code does the initial jump into the procedure. Clients of this code ;; This code does the initial jump into the procedure. Clients of this code
;; are expected to generate the proc-return-multiple and proc-return code afterwards. ;; are expected to generate the proc-return-multiple and proc-return code afterwards.
[(nontail-jump-into-procedure) [nontail-jump-into-procedure
(append-instruction-sequences (append-instruction-sequences
maybe-install-jump-address
(make-instruction-sequence (make-instruction-sequence
`(,(make-PushControlFrame/Call proc-return) `(,(make-PushControlFrame/Call proc-return)
,(make-GotoStatement entry-point-target))))]) ,(make-GotoStatement entry-point-target))))])
@ -1097,7 +1080,6 @@
(make-SubtractArg cenv-length-with-args (make-Reg 'argcount)) (make-SubtractArg cenv-length-with-args (make-Reg 'argcount))
(make-Reg 'argcount))))])]) (make-Reg 'argcount))))])])
(append-instruction-sequences (append-instruction-sequences
maybe-install-jump-address
reuse-the-stack reuse-the-stack
(make-instruction-sequence (make-instruction-sequence
`(;; Assign the proc value of the existing call frame. `(;; Assign the proc value of the existing call frame.

6
il-structs.rkt
View File

@ -29,6 +29,7 @@
SubtractArg SubtractArg
ControlStackLabel ControlStackLabel
ControlStackLabel/MultipleValueReturn ControlStackLabel/MultipleValueReturn
CompiledProcedureEntry
)) ))
@ -68,6 +69,9 @@
(define-struct: ControlStackLabel/MultipleValueReturn () (define-struct: ControlStackLabel/MultipleValueReturn ()
#:transparent) #:transparent)
;; Get the entry point of a compiled procedure.
(define-struct: CompiledProcedureEntry ([proc : OpArg])
#:transparent)
@ -166,7 +170,7 @@
(define-struct: GotoStatement ([target : (U Label Reg)]) (define-struct: GotoStatement ([target : OpArg])
#:transparent) #:transparent)
(define-struct: PerformStatement ([op : PrimitiveCommand]) (define-struct: PerformStatement ([op : PrimitiveCommand])

4
optimize-il.rkt
View File

@ -69,7 +69,9 @@
[(ControlStackLabel? oparg) [(ControlStackLabel? oparg)
oparg] oparg]
[(ControlStackLabel/MultipleValueReturn? oparg) [(ControlStackLabel/MultipleValueReturn? oparg)
oparg])) oparg]
[(CompiledProcedureEntry? oparg)
(make-CompiledProcedureEntry (adjust-oparg-depth (CompiledProcedureEntry-proc oparg) n))]))
(define-predicate natural? Natural) (define-predicate natural? Natural)

21
simulator.rkt
View File

@ -125,18 +125,9 @@
(: step-goto! (machine GotoStatement -> 'ok)) (: step-goto! (machine GotoStatement -> 'ok))
(define (step-goto! m a-goto) (define (step-goto! m a-goto)
(let: ([t : (U Label Reg) (GotoStatement-target a-goto)]) (let: ([t : Symbol (ensure-symbol (evaluate-oparg m (GotoStatement-target a-goto)))])
(cond [(Label? t) (jump! m t)))
(jump! m (Label-name t))]
[(Reg? t)
(let: ([reg : AtomicRegisterSymbol (Reg-name t)])
(cond [(AtomicRegisterSymbol? reg)
(cond [(eq? reg 'val)
(jump! m (ensure-symbol (machine-val m)))]
[(eq? reg 'proc)
(jump! m (ensure-symbol (machine-proc m)))]
[(eq? reg 'argcount)
(error 'goto "argcount misused as jump source")])]))])))
(: step-assign-immediate! (machine AssignImmediateStatement -> 'ok)) (: step-assign-immediate! (machine AssignImmediateStatement -> 'ok))
(define (step-assign-immediate! m stmt) (define (step-assign-immediate! m stmt)
@ -751,7 +742,11 @@
(LinkedLabel-linked-to label))] (LinkedLabel-linked-to label))]
[(CallFrame? frame) [(CallFrame? frame)
(let ([label (CallFrame-return frame)]) (let ([label (CallFrame-return frame)])
(LinkedLabel-linked-to label))]))])) (LinkedLabel-linked-to label))]))]
[(CompiledProcedureEntry? an-oparg)
(let ([proc (ensure-closure (evaluate-oparg m (CompiledProcedureEntry-proc an-oparg)))])
(closure-label proc))]))
(: ensure-closure-or-false (SlotValue -> (U closure #f))) (: ensure-closure-or-false (SlotValue -> (U closure #f)))