trying to hold onto the list of entry points so we can more intelligently emit the blocks
This commit is contained in:
Danny Yoo
parent
c0d816e117
commit
2d62faf794
|
|
@ -7,12 +7,11 @@
|
|||
"kernel-primitives.rkt"
|
||||
"optimize-il.rkt"
|
||||
"analyzer-structs.rkt"
|
||||
#;"analyzer.rkt"
|
||||
"../parameters.rkt"
|
||||
"../sets.rkt"
|
||||
racket/match
|
||||
racket/bool
|
||||
racket/list)
|
||||
racket/list
|
||||
racket/match)
|
||||
(require/typed "../logger.rkt"
|
||||
[log-debug (String -> Void)])
|
||||
|
||||
|
|
@ -22,9 +21,6 @@
|
|||
|
||||
|
||||
|
||||
#;(: current-analysis (Parameterof Analysis))
|
||||
#;(define current-analysis (make-parameter (empty-analysis)))
|
||||
|
||||
|
||||
|
||||
(: -compile (Expression Target Linkage -> (Listof Statement)))
|
||||
|
|
@ -543,8 +539,7 @@
|
|||
(: compile-branch (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
;; Compiles a conditional branch.
|
||||
(define (compile-branch exp cenv target linkage)
|
||||
(let: ([t-branch : Symbol (make-label 'trueBranch)]
|
||||
[f-branch : Symbol (make-label 'falseBranch)]
|
||||
(let: ([f-branch : Symbol (make-label 'falseBranch)]
|
||||
[after-if : Symbol (make-label 'afterIf)])
|
||||
(let ([consequent-linkage
|
||||
(cond
|
||||
|
|
@ -564,7 +559,6 @@
|
|||
(make-instruction-sequence
|
||||
`(,(make-TestAndJumpStatement (make-TestFalse (make-Reg 'val))
|
||||
f-branch)))
|
||||
t-branch
|
||||
c-code
|
||||
f-branch
|
||||
a-code
|
||||
|
|
|
|||
|
|
@ -4,9 +4,7 @@
|
|||
"assemble-helpers.rkt"
|
||||
"assemble-open-coded.rkt"
|
||||
"../compiler/il-structs.rkt"
|
||||
"../compiler/lexical-structs.rkt"
|
||||
racket/string
|
||||
racket/list)
|
||||
racket/string)
|
||||
|
||||
(provide assemble-op-expression)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,23 +1,21 @@
|
|||
#lang typed/racket/base
|
||||
(require "assemble-structs.rkt"
|
||||
"assemble-helpers.rkt"
|
||||
"assemble-open-coded.rkt"
|
||||
"assemble-expression.rkt"
|
||||
"assemble-perform-statement.rkt"
|
||||
"collect-jump-targets.rkt"
|
||||
"../compiler/il-structs.rkt"
|
||||
"../compiler/lexical-structs.rkt"
|
||||
"../compiler/expression-structs.rkt"
|
||||
"../helpers.rkt"
|
||||
"optimize-basic-blocks.rkt"
|
||||
"fracture.rkt"
|
||||
racket/string
|
||||
racket/list)
|
||||
(require/typed "../logger.rkt"
|
||||
[log-debug (String -> Void)])
|
||||
|
||||
(provide assemble/write-invoke
|
||||
assemble-statement)
|
||||
|
||||
|
||||
|
||||
;; Parameter that controls the generation of a trace.
|
||||
(define current-emit-debug-trace? (make-parameter #f))
|
||||
|
||||
|
|
@ -32,27 +30,36 @@
|
|||
(fprintf op "(function(MACHINE, success, fail, params) {\n")
|
||||
(fprintf op "var param;\n")
|
||||
(fprintf op "var RUNTIME = plt.runtime;\n")
|
||||
(let: ([basic-blocks : (Listof BasicBlock)
|
||||
(optimize-basic-blocks (fracture stmts))])
|
||||
(for-each
|
||||
(lambda: ([basic-block : BasicBlock])
|
||||
(displayln (assemble-basic-block basic-block) op)
|
||||
(newline op))
|
||||
basic-blocks)
|
||||
(write-linked-label-attributes stmts op)
|
||||
|
||||
(fprintf op "MACHINE.params.currentErrorHandler = fail;\n")
|
||||
(fprintf op "MACHINE.params.currentSuccessHandler = success;\n")
|
||||
(fprintf op #<<EOF
|
||||
|
||||
(define-values (basic-blocks entry-points) (fracture stmts))
|
||||
(define optimized-basic-blocks (optimize-basic-blocks basic-blocks))
|
||||
|
||||
(write-blocks optimized-basic-blocks op)
|
||||
|
||||
(write-linked-label-attributes stmts op)
|
||||
|
||||
(fprintf op "MACHINE.params.currentErrorHandler = fail;\n")
|
||||
(fprintf op "MACHINE.params.currentSuccessHandler = success;\n")
|
||||
(fprintf op #<<EOF
|
||||
for (param in params) {
|
||||
if (params.hasOwnProperty(param)) {
|
||||
MACHINE.params[param] = params[param];
|
||||
}
|
||||
}
|
||||
EOF
|
||||
)
|
||||
(fprintf op "RUNTIME.trampoline(MACHINE, ~a); })"
|
||||
(assemble-label (make-Label (BasicBlock-name (first basic-blocks)))))))
|
||||
)
|
||||
(fprintf op "RUNTIME.trampoline(MACHINE, ~a); })"
|
||||
(assemble-label (make-Label (BasicBlock-name (first basic-blocks))))))
|
||||
|
||||
|
||||
|
||||
(: write-blocks ((Listof BasicBlock) Output-Port -> Void))
|
||||
;; Write out all the basic blocks.
|
||||
(define (write-blocks blocks op)
|
||||
(for ([b blocks])
|
||||
(log-debug (format "Emitting code for basic block ~s" (BasicBlock-name b)))
|
||||
(displayln (assemble-basic-block b) op)
|
||||
(newline op)))
|
||||
|
||||
|
||||
|
||||
|
|
@ -152,7 +159,7 @@ EOF
|
|||
[(TestAndJumpStatement? stmt)
|
||||
(let*: ([test : PrimitiveTest (TestAndJumpStatement-op stmt)]
|
||||
[jump : String (assemble-jump
|
||||
(make-Label (TestAndJumpStatement-label stmt)))])
|
||||
(make-Label (TestAndJumpStatement-label stmt)))])
|
||||
;; to help localize type checks, we add a type annotation here.
|
||||
(ann (cond
|
||||
[(TestFalse? test)
|
||||
|
|
|
|||
|
|
@ -1,177 +1,344 @@
|
|||
#lang typed/racket/base
|
||||
(require "../compiler/expression-structs.rkt"
|
||||
"../compiler/il-structs.rkt"
|
||||
"../compiler/lexical-structs.rkt"
|
||||
"../helpers.rkt"
|
||||
racket/list)
|
||||
"../compiler/lexical-structs.rkt"
|
||||
"../helpers.rkt"
|
||||
racket/list)
|
||||
|
||||
(provide collect-general-jump-targets)
|
||||
(provide collect-general-jump-targets
|
||||
collect-entry-points)
|
||||
|
||||
|
||||
|
||||
(: collect-general-jump-targets ((Listof Statement) -> (Listof Symbol)))
|
||||
;; collects all the labels that are potential targets for GOTOs or branches.
|
||||
(define (collect-general-jump-targets stmts)
|
||||
|
||||
(: collect-statement (Statement -> (Listof Symbol)))
|
||||
(define (collect-statement stmt)
|
||||
(cond
|
||||
[(symbol? stmt)
|
||||
empty]
|
||||
[(LinkedLabel? stmt)
|
||||
(list (LinkedLabel-label stmt)
|
||||
(LinkedLabel-linked-to stmt))]
|
||||
[(DebugPrint? stmt)
|
||||
empty]
|
||||
[(AssignImmediateStatement? stmt)
|
||||
(let: ([v : OpArg (AssignImmediateStatement-value stmt)])
|
||||
(collect-input v))]
|
||||
[(AssignPrimOpStatement? stmt)
|
||||
(collect-primitive-operator (AssignPrimOpStatement-op stmt))]
|
||||
[(PerformStatement? stmt)
|
||||
(collect-primitive-command (PerformStatement-op stmt))]
|
||||
[(TestAndJumpStatement? stmt)
|
||||
(list (TestAndJumpStatement-label stmt))]
|
||||
[(GotoStatement? stmt)
|
||||
(collect-input (GotoStatement-target stmt))]
|
||||
[(PushEnvironment? stmt)
|
||||
empty]
|
||||
[(PopEnvironment? stmt)
|
||||
empty]
|
||||
[(PushImmediateOntoEnvironment? stmt)
|
||||
(collect-input (PushImmediateOntoEnvironment-value stmt))]
|
||||
[(PushControlFrame/Generic? stmt)
|
||||
empty]
|
||||
[(PushControlFrame/Call? stmt)
|
||||
(label->labels (PushControlFrame/Call-label stmt))]
|
||||
[(PushControlFrame/Prompt? stmt)
|
||||
(label->labels (PushControlFrame/Prompt-label stmt))]
|
||||
[(PopControlFrame? stmt)
|
||||
empty]
|
||||
[(Comment? stmt)
|
||||
empty]))
|
||||
|
||||
|
||||
|
||||
(: collect-input (OpArg -> (Listof Symbol)))
|
||||
(define (collect-input an-input)
|
||||
(cond
|
||||
[(Reg? an-input)
|
||||
empty]
|
||||
[(Const? an-input)
|
||||
empty]
|
||||
[(Label? an-input)
|
||||
(list (Label-name an-input))]
|
||||
[(EnvLexicalReference? an-input)
|
||||
empty]
|
||||
[(EnvPrefixReference? an-input)
|
||||
empty]
|
||||
[(EnvWholePrefixReference? an-input)
|
||||
empty]
|
||||
[(SubtractArg? an-input)
|
||||
(append (collect-input (SubtractArg-lhs an-input))
|
||||
(collect-input (SubtractArg-rhs an-input)))]
|
||||
[(ControlStackLabel? an-input)
|
||||
empty]
|
||||
[(ControlStackLabel/MultipleValueReturn? an-input)
|
||||
empty]
|
||||
[(ControlFrameTemporary? an-input)
|
||||
empty]
|
||||
[(CompiledProcedureEntry? an-input)
|
||||
(collect-input (CompiledProcedureEntry-proc an-input))]
|
||||
[(CompiledProcedureClosureReference? an-input)
|
||||
(collect-input (CompiledProcedureClosureReference-proc an-input))]
|
||||
[(PrimitiveKernelValue? an-input)
|
||||
empty]
|
||||
[(ModuleEntry? an-input)
|
||||
empty]
|
||||
[(IsModuleInvoked? an-input)
|
||||
empty]
|
||||
[(IsModuleLinked? an-input)
|
||||
empty]
|
||||
[(VariableReference? an-input)
|
||||
empty]))
|
||||
|
||||
|
||||
(: collect-location ((U Reg Label) -> (Listof Symbol)))
|
||||
(define (collect-location a-location)
|
||||
(cond
|
||||
[(Reg? a-location)
|
||||
empty]
|
||||
[(Label? a-location)
|
||||
(list (Label-name a-location))]))
|
||||
|
||||
(: collect-primitive-operator (PrimitiveOperator -> (Listof Symbol)))
|
||||
(define (collect-primitive-operator op)
|
||||
(cond
|
||||
[(GetCompiledProcedureEntry? op)
|
||||
empty]
|
||||
[(MakeCompiledProcedure? op)
|
||||
(list (MakeCompiledProcedure-label op))]
|
||||
[(MakeCompiledProcedureShell? op)
|
||||
(list (MakeCompiledProcedureShell-label op))]
|
||||
[(ApplyPrimitiveProcedure? op)
|
||||
empty]
|
||||
[(CaptureEnvironment? op)
|
||||
empty]
|
||||
[(CaptureControl? op)
|
||||
empty]
|
||||
[(MakeBoxedEnvironmentValue? op)
|
||||
empty]
|
||||
[(CallKernelPrimitiveProcedure? op)
|
||||
empty]))
|
||||
|
||||
(: collect-primitive-command (PrimitiveCommand -> (Listof Symbol)))
|
||||
(define (collect-primitive-command op)
|
||||
(cond
|
||||
[(InstallModuleEntry!? op)
|
||||
(list (InstallModuleEntry!-entry-point op))]
|
||||
[else
|
||||
empty]
|
||||
;; currently written this way because I'm hitting some bad type-checking behavior.
|
||||
#;([(CheckToplevelBound!? op)
|
||||
empty]
|
||||
[(CheckClosureArity!? op)
|
||||
empty]
|
||||
[(CheckPrimitiveArity!? op)
|
||||
empty]
|
||||
[(ExtendEnvironment/Prefix!? op)
|
||||
empty]
|
||||
[(InstallClosureValues!? op)
|
||||
empty]
|
||||
[(RestoreEnvironment!? op)
|
||||
empty]
|
||||
[(RestoreControl!? op)
|
||||
empty]
|
||||
[(SetFrameCallee!? op)
|
||||
empty]
|
||||
[(SpliceListIntoStack!? op)
|
||||
empty]
|
||||
[(UnspliceRestFromStack!? op)
|
||||
empty]
|
||||
[(FixClosureShellMap!? op)
|
||||
empty]
|
||||
[(InstallContinuationMarkEntry!? op)
|
||||
empty]
|
||||
[(RaiseContextExpectedValuesError!? op)
|
||||
empty]
|
||||
[(RaiseArityMismatchError!? op)
|
||||
empty]
|
||||
[(RaiseOperatorApplicationError!? op)
|
||||
empty])))
|
||||
|
||||
|
||||
(unique/eq?
|
||||
(let: loop : (Listof Symbol) ([stmts : (Listof Statement) stmts])
|
||||
(cond [(empty? stmts)
|
||||
empty]
|
||||
[else
|
||||
(let: ([stmt : Statement (first stmts)])
|
||||
(append (collect-statement stmt)
|
||||
(loop (rest stmts))))]))))
|
||||
(cond [(empty? stmts)
|
||||
empty]
|
||||
[else
|
||||
(let: ([stmt : Statement (first stmts)])
|
||||
(append (collect-statement stmt)
|
||||
(loop (rest stmts))))]))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(: collect-statement (Statement -> (Listof Symbol)))
|
||||
(define (collect-statement stmt)
|
||||
(cond
|
||||
[(symbol? stmt)
|
||||
empty]
|
||||
[(LinkedLabel? stmt)
|
||||
(list (LinkedLabel-label stmt)
|
||||
(LinkedLabel-linked-to stmt))]
|
||||
[(DebugPrint? stmt)
|
||||
empty]
|
||||
[(AssignImmediateStatement? stmt)
|
||||
(let: ([v : OpArg (AssignImmediateStatement-value stmt)])
|
||||
(collect-input v))]
|
||||
[(AssignPrimOpStatement? stmt)
|
||||
(collect-primitive-operator (AssignPrimOpStatement-op stmt))]
|
||||
[(PerformStatement? stmt)
|
||||
(collect-primitive-command (PerformStatement-op stmt))]
|
||||
[(TestAndJumpStatement? stmt)
|
||||
(list (TestAndJumpStatement-label stmt))]
|
||||
[(GotoStatement? stmt)
|
||||
(collect-input (GotoStatement-target stmt))]
|
||||
[(PushEnvironment? stmt)
|
||||
empty]
|
||||
[(PopEnvironment? stmt)
|
||||
empty]
|
||||
[(PushImmediateOntoEnvironment? stmt)
|
||||
(collect-input (PushImmediateOntoEnvironment-value stmt))]
|
||||
[(PushControlFrame/Generic? stmt)
|
||||
empty]
|
||||
[(PushControlFrame/Call? stmt)
|
||||
(label->labels (PushControlFrame/Call-label stmt))]
|
||||
[(PushControlFrame/Prompt? stmt)
|
||||
(label->labels (PushControlFrame/Prompt-label stmt))]
|
||||
[(PopControlFrame? stmt)
|
||||
empty]
|
||||
[(Comment? stmt)
|
||||
empty]))
|
||||
|
||||
(: collect-entry-points ((Listof Statement) -> (Listof Symbol)))
|
||||
;; collects all the labels that are general entry points. The entry points are
|
||||
;; from the starting basic block, from functions headers, and finally return points.
|
||||
(define (collect-entry-points stmts)
|
||||
|
||||
(: collect-statement (Statement -> (Listof Symbol)))
|
||||
(define (collect-statement stmt)
|
||||
(cond
|
||||
[(symbol? stmt)
|
||||
empty]
|
||||
[(LinkedLabel? stmt)
|
||||
(list (LinkedLabel-label stmt)
|
||||
(LinkedLabel-linked-to stmt))]
|
||||
[(DebugPrint? stmt)
|
||||
empty]
|
||||
[(AssignImmediateStatement? stmt)
|
||||
(let: ([v : OpArg (AssignImmediateStatement-value stmt)])
|
||||
(collect-input v))]
|
||||
[(AssignPrimOpStatement? stmt)
|
||||
(collect-primitive-operator (AssignPrimOpStatement-op stmt))]
|
||||
[(PerformStatement? stmt)
|
||||
(collect-primitive-command (PerformStatement-op stmt))]
|
||||
[(TestAndJumpStatement? stmt)
|
||||
empty]
|
||||
[(GotoStatement? stmt)
|
||||
empty]
|
||||
[(PushEnvironment? stmt)
|
||||
empty]
|
||||
[(PopEnvironment? stmt)
|
||||
empty]
|
||||
[(PushImmediateOntoEnvironment? stmt)
|
||||
(collect-input (PushImmediateOntoEnvironment-value stmt))]
|
||||
[(PushControlFrame/Generic? stmt)
|
||||
empty]
|
||||
[(PushControlFrame/Call? stmt)
|
||||
(label->labels (PushControlFrame/Call-label stmt))]
|
||||
[(PushControlFrame/Prompt? stmt)
|
||||
(label->labels (PushControlFrame/Prompt-label stmt))]
|
||||
[(PopControlFrame? stmt)
|
||||
empty]
|
||||
[(Comment? stmt)
|
||||
empty]))
|
||||
|
||||
|
||||
|
||||
(: collect-input (OpArg -> (Listof Symbol)))
|
||||
(define (collect-input an-input)
|
||||
(cond
|
||||
[(Reg? an-input)
|
||||
empty]
|
||||
[(Const? an-input)
|
||||
empty]
|
||||
[(Label? an-input)
|
||||
(list (Label-name an-input))]
|
||||
[(EnvLexicalReference? an-input)
|
||||
empty]
|
||||
[(EnvPrefixReference? an-input)
|
||||
empty]
|
||||
[(EnvWholePrefixReference? an-input)
|
||||
empty]
|
||||
[(SubtractArg? an-input)
|
||||
(append (collect-input (SubtractArg-lhs an-input))
|
||||
(collect-input (SubtractArg-rhs an-input)))]
|
||||
[(ControlStackLabel? an-input)
|
||||
empty]
|
||||
[(ControlStackLabel/MultipleValueReturn? an-input)
|
||||
empty]
|
||||
[(ControlFrameTemporary? an-input)
|
||||
empty]
|
||||
[(CompiledProcedureEntry? an-input)
|
||||
(collect-input (CompiledProcedureEntry-proc an-input))]
|
||||
[(CompiledProcedureClosureReference? an-input)
|
||||
(collect-input (CompiledProcedureClosureReference-proc an-input))]
|
||||
[(PrimitiveKernelValue? an-input)
|
||||
empty]
|
||||
[(ModuleEntry? an-input)
|
||||
empty]
|
||||
[(IsModuleInvoked? an-input)
|
||||
empty]
|
||||
[(IsModuleLinked? an-input)
|
||||
empty]
|
||||
[(VariableReference? an-input)
|
||||
empty]))
|
||||
|
||||
|
||||
(: collect-location ((U Reg Label) -> (Listof Symbol)))
|
||||
(define (collect-location a-location)
|
||||
(cond
|
||||
[(Reg? a-location)
|
||||
empty]
|
||||
[(Label? a-location)
|
||||
(list (Label-name a-location))]))
|
||||
|
||||
(: collect-primitive-operator (PrimitiveOperator -> (Listof Symbol)))
|
||||
(define (collect-primitive-operator op)
|
||||
(cond
|
||||
[(GetCompiledProcedureEntry? op)
|
||||
empty]
|
||||
[(MakeCompiledProcedure? op)
|
||||
(list (MakeCompiledProcedure-label op))]
|
||||
[(MakeCompiledProcedureShell? op)
|
||||
(list (MakeCompiledProcedureShell-label op))]
|
||||
[(ApplyPrimitiveProcedure? op)
|
||||
empty]
|
||||
[(CaptureEnvironment? op)
|
||||
empty]
|
||||
[(CaptureControl? op)
|
||||
empty]
|
||||
[(MakeBoxedEnvironmentValue? op)
|
||||
empty]
|
||||
[(CallKernelPrimitiveProcedure? op)
|
||||
empty]))
|
||||
|
||||
(: collect-primitive-command (PrimitiveCommand -> (Listof Symbol)))
|
||||
(define (collect-primitive-command op)
|
||||
(cond
|
||||
[(InstallModuleEntry!? op)
|
||||
(list (InstallModuleEntry!-entry-point op))]
|
||||
[else
|
||||
empty]
|
||||
;; currently written this way because I'm hitting some bad type-checking behavior.
|
||||
#;([(CheckToplevelBound!? op)
|
||||
empty]
|
||||
[(CheckClosureArity!? op)
|
||||
empty]
|
||||
[(CheckPrimitiveArity!? op)
|
||||
empty]
|
||||
[(ExtendEnvironment/Prefix!? op)
|
||||
empty]
|
||||
[(InstallClosureValues!? op)
|
||||
empty]
|
||||
[(RestoreEnvironment!? op)
|
||||
empty]
|
||||
[(RestoreControl!? op)
|
||||
empty]
|
||||
[(SetFrameCallee!? op)
|
||||
empty]
|
||||
[(SpliceListIntoStack!? op)
|
||||
empty]
|
||||
[(UnspliceRestFromStack!? op)
|
||||
empty]
|
||||
[(FixClosureShellMap!? op)
|
||||
empty]
|
||||
[(InstallContinuationMarkEntry!? op)
|
||||
empty]
|
||||
[(RaiseContextExpectedValuesError!? op)
|
||||
empty]
|
||||
[(RaiseArityMismatchError!? op)
|
||||
empty]
|
||||
[(RaiseOperatorApplicationError!? op)
|
||||
empty])))
|
||||
|
||||
|
||||
(unique/eq?
|
||||
(let: loop : (Listof Symbol) ([stmts : (Listof Statement) stmts])
|
||||
(cond [(empty? stmts)
|
||||
empty]
|
||||
[else
|
||||
(let: ([stmt : Statement (first stmts)])
|
||||
(append (collect-statement stmt)
|
||||
(loop (rest stmts))))]))))
|
||||
|
||||
|
||||
(: collect-input (OpArg -> (Listof Symbol)))
|
||||
(define (collect-input an-input)
|
||||
(cond
|
||||
[(Reg? an-input)
|
||||
empty]
|
||||
[(Const? an-input)
|
||||
empty]
|
||||
[(Label? an-input)
|
||||
(list (Label-name an-input))]
|
||||
[(EnvLexicalReference? an-input)
|
||||
empty]
|
||||
[(EnvPrefixReference? an-input)
|
||||
empty]
|
||||
[(EnvWholePrefixReference? an-input)
|
||||
empty]
|
||||
[(SubtractArg? an-input)
|
||||
(append (collect-input (SubtractArg-lhs an-input))
|
||||
(collect-input (SubtractArg-rhs an-input)))]
|
||||
[(ControlStackLabel? an-input)
|
||||
empty]
|
||||
[(ControlStackLabel/MultipleValueReturn? an-input)
|
||||
empty]
|
||||
[(ControlFrameTemporary? an-input)
|
||||
empty]
|
||||
[(CompiledProcedureEntry? an-input)
|
||||
(collect-input (CompiledProcedureEntry-proc an-input))]
|
||||
[(CompiledProcedureClosureReference? an-input)
|
||||
(collect-input (CompiledProcedureClosureReference-proc an-input))]
|
||||
[(PrimitiveKernelValue? an-input)
|
||||
empty]
|
||||
[(ModuleEntry? an-input)
|
||||
empty]
|
||||
[(IsModuleInvoked? an-input)
|
||||
empty]
|
||||
[(IsModuleLinked? an-input)
|
||||
empty]
|
||||
[(VariableReference? an-input)
|
||||
empty]))
|
||||
|
||||
|
||||
(: collect-location ((U Reg Label) -> (Listof Symbol)))
|
||||
(define (collect-location a-location)
|
||||
(cond
|
||||
[(Reg? a-location)
|
||||
empty]
|
||||
[(Label? a-location)
|
||||
(list (Label-name a-location))]))
|
||||
|
||||
(: collect-primitive-operator (PrimitiveOperator -> (Listof Symbol)))
|
||||
(define (collect-primitive-operator op)
|
||||
(cond
|
||||
[(GetCompiledProcedureEntry? op)
|
||||
empty]
|
||||
[(MakeCompiledProcedure? op)
|
||||
(list (MakeCompiledProcedure-label op))]
|
||||
[(MakeCompiledProcedureShell? op)
|
||||
(list (MakeCompiledProcedureShell-label op))]
|
||||
[(ApplyPrimitiveProcedure? op)
|
||||
empty]
|
||||
[(CaptureEnvironment? op)
|
||||
empty]
|
||||
[(CaptureControl? op)
|
||||
empty]
|
||||
[(MakeBoxedEnvironmentValue? op)
|
||||
empty]
|
||||
[(CallKernelPrimitiveProcedure? op)
|
||||
empty]))
|
||||
|
||||
(: collect-primitive-command (PrimitiveCommand -> (Listof Symbol)))
|
||||
(define (collect-primitive-command op)
|
||||
(cond
|
||||
[(InstallModuleEntry!? op)
|
||||
(list (InstallModuleEntry!-entry-point op))]
|
||||
[else
|
||||
empty]
|
||||
;; currently written this way because I'm hitting some bad type-checking behavior.
|
||||
#;([(CheckToplevelBound!? op)
|
||||
empty]
|
||||
[(CheckClosureArity!? op)
|
||||
empty]
|
||||
[(CheckPrimitiveArity!? op)
|
||||
empty]
|
||||
[(ExtendEnvironment/Prefix!? op)
|
||||
empty]
|
||||
[(InstallClosureValues!? op)
|
||||
empty]
|
||||
[(RestoreEnvironment!? op)
|
||||
empty]
|
||||
[(RestoreControl!? op)
|
||||
empty]
|
||||
[(SetFrameCallee!? op)
|
||||
empty]
|
||||
[(SpliceListIntoStack!? op)
|
||||
empty]
|
||||
[(UnspliceRestFromStack!? op)
|
||||
empty]
|
||||
[(FixClosureShellMap!? op)
|
||||
empty]
|
||||
[(InstallContinuationMarkEntry!? op)
|
||||
empty]
|
||||
[(RaiseContextExpectedValuesError!? op)
|
||||
empty]
|
||||
[(RaiseArityMismatchError!? op)
|
||||
empty]
|
||||
[(RaiseOperatorApplicationError!? op)
|
||||
empty])))
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -180,9 +347,9 @@
|
|||
(: label->labels ((U Symbol LinkedLabel) -> (Listof Symbol)))
|
||||
(define (label->labels label)
|
||||
(cond
|
||||
[(symbol? label)
|
||||
(list label)]
|
||||
[(LinkedLabel? label)
|
||||
(list (LinkedLabel-label label)
|
||||
(LinkedLabel-linked-to label))]))
|
||||
[(symbol? label)
|
||||
(list label)]
|
||||
[(LinkedLabel? label)
|
||||
(list (LinkedLabel-label label)
|
||||
(LinkedLabel-linked-to label))]))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,26 +1,30 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require "assemble-structs.rkt"
|
||||
"assemble-helpers.rkt"
|
||||
"assemble-open-coded.rkt"
|
||||
"assemble-expression.rkt"
|
||||
"assemble-perform-statement.rkt"
|
||||
"collect-jump-targets.rkt"
|
||||
"../compiler/il-structs.rkt"
|
||||
"../compiler/lexical-structs.rkt"
|
||||
"../compiler/expression-structs.rkt"
|
||||
"../helpers.rkt"
|
||||
racket/string
|
||||
racket/list)
|
||||
|
||||
|
||||
;; Breaks up a sequence of statements into a list of basic blocks.
|
||||
;;
|
||||
;; The first basic block is special, and represents the start of execution.
|
||||
;;
|
||||
;; A basic block consists of a sequence of straight line statements, followed by one of
|
||||
;; the following:
|
||||
;;
|
||||
;; * A conditional jump.
|
||||
;; * An unconditional jump.
|
||||
;; * Termination.
|
||||
|
||||
(provide fracture)
|
||||
|
||||
|
||||
|
||||
|
||||
;; fracture: (listof stmt) -> (listof basic-block)
|
||||
(: fracture ((Listof Statement) -> (Listof BasicBlock)))
|
||||
(: fracture ((Listof Statement) -> (values (Listof BasicBlock)
|
||||
(Listof Symbol))))
|
||||
(define (fracture stmts)
|
||||
(let*: ([first-block-label : Symbol (if (and (not (empty? stmts))
|
||||
(symbol? (first stmts)))
|
||||
|
|
@ -31,48 +35,52 @@
|
|||
(rest stmts)
|
||||
stmts)]
|
||||
[jump-targets : (Listof Symbol)
|
||||
(cons first-block-label (collect-general-jump-targets stmts))])
|
||||
(let: loop : (Listof BasicBlock)
|
||||
([name : Symbol first-block-label]
|
||||
[acc : (Listof UnlabeledStatement) '()]
|
||||
[basic-blocks : (Listof BasicBlock) '()]
|
||||
[stmts : (Listof Statement) stmts]
|
||||
[last-stmt-goto? : Boolean #f])
|
||||
(cond
|
||||
[(null? stmts)
|
||||
(reverse (cons (make-BasicBlock name (reverse acc))
|
||||
basic-blocks))]
|
||||
[else
|
||||
(let: ([first-stmt : Statement (car stmts)])
|
||||
(: do-on-label (Symbol -> (Listof BasicBlock)))
|
||||
(define (do-on-label label-name)
|
||||
(cond
|
||||
[(member label-name jump-targets)
|
||||
(loop label-name
|
||||
'()
|
||||
(cons (make-BasicBlock
|
||||
name
|
||||
(if last-stmt-goto?
|
||||
(reverse acc)
|
||||
(reverse (append `(,(make-GotoStatement (make-Label label-name)))
|
||||
acc))))
|
||||
basic-blocks)
|
||||
(cdr stmts)
|
||||
last-stmt-goto?)]
|
||||
[else
|
||||
(loop name
|
||||
acc
|
||||
basic-blocks
|
||||
(cdr stmts)
|
||||
last-stmt-goto?)]))
|
||||
(cond
|
||||
[(symbol? first-stmt)
|
||||
(do-on-label first-stmt)]
|
||||
[(LinkedLabel? first-stmt)
|
||||
(do-on-label (LinkedLabel-label first-stmt))]
|
||||
[else
|
||||
(loop name
|
||||
(cons first-stmt acc)
|
||||
basic-blocks
|
||||
(cdr stmts)
|
||||
(GotoStatement? (car stmts)))]))]))))
|
||||
(cons first-block-label (collect-general-jump-targets stmts))]
|
||||
[entry-points : (Listof Symbol)
|
||||
(cons first-block-label (collect-entry-points stmts))])
|
||||
|
||||
(let: loop : (values (Listof BasicBlock) (Listof Symbol))
|
||||
([name : Symbol first-block-label]
|
||||
[acc : (Listof UnlabeledStatement) '()]
|
||||
[basic-blocks : (Listof BasicBlock) '()]
|
||||
[stmts : (Listof Statement) stmts]
|
||||
[last-stmt-goto? : Boolean #f])
|
||||
(cond
|
||||
[(null? stmts)
|
||||
(values (reverse (cons (make-BasicBlock name (reverse acc))
|
||||
basic-blocks))
|
||||
entry-points)]
|
||||
[else
|
||||
(let: ([first-stmt : Statement (car stmts)])
|
||||
(: do-on-label (Symbol -> (values (Listof BasicBlock) (Listof Symbol))))
|
||||
(define (do-on-label label-name)
|
||||
(cond
|
||||
[(member label-name jump-targets)
|
||||
(loop label-name
|
||||
'()
|
||||
(cons (make-BasicBlock
|
||||
name
|
||||
(if last-stmt-goto?
|
||||
(reverse acc)
|
||||
(reverse (append `(,(make-GotoStatement (make-Label label-name)))
|
||||
acc))))
|
||||
basic-blocks)
|
||||
(cdr stmts)
|
||||
last-stmt-goto?)]
|
||||
[else
|
||||
(loop name
|
||||
acc
|
||||
basic-blocks
|
||||
(cdr stmts)
|
||||
last-stmt-goto?)]))
|
||||
(cond
|
||||
[(symbol? first-stmt)
|
||||
(do-on-label first-stmt)]
|
||||
[(LinkedLabel? first-stmt)
|
||||
(do-on-label (LinkedLabel-label first-stmt))]
|
||||
[else
|
||||
(loop name
|
||||
(cons first-stmt acc)
|
||||
basic-blocks
|
||||
(cdr stmts)
|
||||
(GotoStatement? (car stmts)))]))]))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user