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

trying to hold onto the list of entry points so we can more intelligently emit the blocks

Browse Source
This commit is contained in:
Danny Yoo 2011-08-05 15:02:32 -04:00
parent c0d816e117
commit 2d62faf794
5 changed files with 420 additions and 246 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
compiler/compiler.rkt
View File

@ -7,12 +7,11 @@
"kernel-primitives.rkt" "kernel-primitives.rkt"
"optimize-il.rkt" "optimize-il.rkt"
"analyzer-structs.rkt" "analyzer-structs.rkt"
#;"analyzer.rkt"
"../parameters.rkt" "../parameters.rkt"
"../sets.rkt" "../sets.rkt"
racket/match
racket/bool racket/bool
racket/list) racket/list
racket/match)
(require/typed "../logger.rkt" (require/typed "../logger.rkt"
[log-debug (String -> Void)]) [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))) (: -compile (Expression Target Linkage -> (Listof Statement)))
@ -543,8 +539,7 @@
(: compile-branch (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-branch (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence))
;; Compiles a conditional branch. ;; Compiles a conditional branch.
(define (compile-branch exp cenv target linkage) (define (compile-branch exp cenv target linkage)
(let: ([t-branch : Symbol (make-label 'trueBranch)] (let: ([f-branch : Symbol (make-label 'falseBranch)]
[f-branch : Symbol (make-label 'falseBranch)]
[after-if : Symbol (make-label 'afterIf)]) [after-if : Symbol (make-label 'afterIf)])
(let ([consequent-linkage (let ([consequent-linkage
(cond (cond
@ -564,7 +559,6 @@
(make-instruction-sequence (make-instruction-sequence
`(,(make-TestAndJumpStatement (make-TestFalse (make-Reg 'val)) `(,(make-TestAndJumpStatement (make-TestFalse (make-Reg 'val))
f-branch))) f-branch)))
t-branch
c-code c-code
f-branch f-branch
a-code a-code

4
js-assembler/assemble-expression.rkt
View File

@ -4,9 +4,7 @@
"assemble-helpers.rkt" "assemble-helpers.rkt"
"assemble-open-coded.rkt" "assemble-open-coded.rkt"
"../compiler/il-structs.rkt" "../compiler/il-structs.rkt"
"../compiler/lexical-structs.rkt" racket/string)
racket/string
racket/list)
(provide assemble-op-expression) (provide assemble-op-expression)

47
js-assembler/assemble.rkt
View File

@ -1,23 +1,21 @@
#lang typed/racket/base #lang typed/racket/base
(require "assemble-structs.rkt" (require "assemble-structs.rkt"
"assemble-helpers.rkt" "assemble-helpers.rkt"
"assemble-open-coded.rkt"
"assemble-expression.rkt" "assemble-expression.rkt"
"assemble-perform-statement.rkt" "assemble-perform-statement.rkt"
"collect-jump-targets.rkt"
"../compiler/il-structs.rkt" "../compiler/il-structs.rkt"
"../compiler/lexical-structs.rkt"
"../compiler/expression-structs.rkt"
"../helpers.rkt"
"optimize-basic-blocks.rkt" "optimize-basic-blocks.rkt"
"fracture.rkt" "fracture.rkt"
racket/string racket/string
racket/list) racket/list)
(require/typed "../logger.rkt"
[log-debug (String -> Void)])
(provide assemble/write-invoke (provide assemble/write-invoke
assemble-statement) assemble-statement)
;; Parameter that controls the generation of a trace. ;; Parameter that controls the generation of a trace.
(define current-emit-debug-trace? (make-parameter #f)) (define current-emit-debug-trace? (make-parameter #f))
@ -32,27 +30,36 @@
(fprintf op "(function(MACHINE, success, fail, params) {\n") (fprintf op "(function(MACHINE, success, fail, params) {\n")
(fprintf op "var param;\n") (fprintf op "var param;\n")
(fprintf op "var RUNTIME = plt.runtime;\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") (define-values (basic-blocks entry-points) (fracture stmts))
(fprintf op "MACHINE.params.currentSuccessHandler = success;\n") (define optimized-basic-blocks (optimize-basic-blocks basic-blocks))
(fprintf op #<<EOF
(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) { for (param in params) {
if (params.hasOwnProperty(param)) { if (params.hasOwnProperty(param)) {
MACHINE.params[param] = params[param]; MACHINE.params[param] = params[param];
} }
} }
EOF EOF
) )
(fprintf op "RUNTIME.trampoline(MACHINE, ~a); })" (fprintf op "RUNTIME.trampoline(MACHINE, ~a); })"
(assemble-label (make-Label (BasicBlock-name (first basic-blocks))))))) (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) [(TestAndJumpStatement? stmt)
(let*: ([test : PrimitiveTest (TestAndJumpStatement-op stmt)] (let*: ([test : PrimitiveTest (TestAndJumpStatement-op stmt)]
[jump : String (assemble-jump [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. ;; to help localize type checks, we add a type annotation here.
(ann (cond (ann (cond
[(TestFalse? test) [(TestFalse? test)

475
js-assembler/collect-jump-targets.rkt
View File

@ -1,176 +1,343 @@
#lang typed/racket/base #lang typed/racket/base
(require "../compiler/expression-structs.rkt" (require "../compiler/expression-structs.rkt"
"../compiler/il-structs.rkt" "../compiler/il-structs.rkt"
"../compiler/lexical-structs.rkt" "../compiler/lexical-structs.rkt"
"../helpers.rkt" "../helpers.rkt"
racket/list) racket/list)
(provide collect-general-jump-targets) (provide collect-general-jump-targets
collect-entry-points)
(: collect-general-jump-targets ((Listof Statement) -> (Listof Symbol))) (: collect-general-jump-targets ((Listof Statement) -> (Listof Symbol)))
;; collects all the labels that are potential targets for GOTOs or branches. ;; collects all the labels that are potential targets for GOTOs or branches.
(define (collect-general-jump-targets stmts) (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? (unique/eq?
(let: loop : (Listof Symbol) ([stmts : (Listof Statement) stmts]) (let: loop : (Listof Symbol) ([stmts : (Listof Statement) stmts])
(cond [(empty? stmts) (cond [(empty? stmts)
empty] empty]
[else [else
(let: ([stmt : Statement (first stmts)]) (let: ([stmt : Statement (first stmts)])
(append (collect-statement stmt) (append (collect-statement stmt)
(loop (rest stmts))))])))) (loop (rest stmts))))]))))
(: collect-statement (Statement -> (Listof Symbol)))
(define (collect-statement stmt) (: collect-entry-points ((Listof Statement) -> (Listof Symbol)))
(cond ;; collects all the labels that are general entry points. The entry points are
[(symbol? stmt) ;; from the starting basic block, from functions headers, and finally return points.
empty] (define (collect-entry-points stmts)
[(LinkedLabel? stmt)
(list (LinkedLabel-label stmt) (: collect-statement (Statement -> (Listof Symbol)))
(LinkedLabel-linked-to stmt))] (define (collect-statement stmt)
[(DebugPrint? stmt) (cond
empty] [(symbol? stmt)
[(AssignImmediateStatement? stmt) empty]
(let: ([v : OpArg (AssignImmediateStatement-value stmt)]) [(LinkedLabel? stmt)
(collect-input v))] (list (LinkedLabel-label stmt)
[(AssignPrimOpStatement? stmt) (LinkedLabel-linked-to stmt))]
(collect-primitive-operator (AssignPrimOpStatement-op stmt))] [(DebugPrint? stmt)
[(PerformStatement? stmt) empty]
(collect-primitive-command (PerformStatement-op stmt))] [(AssignImmediateStatement? stmt)
[(TestAndJumpStatement? stmt) (let: ([v : OpArg (AssignImmediateStatement-value stmt)])
(list (TestAndJumpStatement-label stmt))] (collect-input v))]
[(GotoStatement? stmt) [(AssignPrimOpStatement? stmt)
(collect-input (GotoStatement-target stmt))] (collect-primitive-operator (AssignPrimOpStatement-op stmt))]
[(PushEnvironment? stmt) [(PerformStatement? stmt)
empty] (collect-primitive-command (PerformStatement-op stmt))]
[(PopEnvironment? stmt) [(TestAndJumpStatement? stmt)
empty] empty]
[(PushImmediateOntoEnvironment? stmt) [(GotoStatement? stmt)
(collect-input (PushImmediateOntoEnvironment-value stmt))] empty]
[(PushControlFrame/Generic? stmt) [(PushEnvironment? stmt)
empty] empty]
[(PushControlFrame/Call? stmt) [(PopEnvironment? stmt)
(label->labels (PushControlFrame/Call-label stmt))] empty]
[(PushControlFrame/Prompt? stmt) [(PushImmediateOntoEnvironment? stmt)
(label->labels (PushControlFrame/Prompt-label stmt))] (collect-input (PushImmediateOntoEnvironment-value stmt))]
[(PopControlFrame? stmt) [(PushControlFrame/Generic? stmt)
empty] empty]
[(Comment? stmt) [(PushControlFrame/Call? stmt)
empty])) (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))) (: collect-input (OpArg -> (Listof Symbol)))
(define (collect-input an-input) (define (collect-input an-input)
(cond (cond
[(Reg? an-input) [(Reg? an-input)
empty] empty]
[(Const? an-input) [(Const? an-input)
empty] empty]
[(Label? an-input) [(Label? an-input)
(list (Label-name an-input))] (list (Label-name an-input))]
[(EnvLexicalReference? an-input) [(EnvLexicalReference? an-input)
empty] empty]
[(EnvPrefixReference? an-input) [(EnvPrefixReference? an-input)
empty] empty]
[(EnvWholePrefixReference? an-input) [(EnvWholePrefixReference? an-input)
empty] empty]
[(SubtractArg? an-input) [(SubtractArg? an-input)
(append (collect-input (SubtractArg-lhs an-input)) (append (collect-input (SubtractArg-lhs an-input))
(collect-input (SubtractArg-rhs an-input)))] (collect-input (SubtractArg-rhs an-input)))]
[(ControlStackLabel? an-input) [(ControlStackLabel? an-input)
empty] empty]
[(ControlStackLabel/MultipleValueReturn? an-input) [(ControlStackLabel/MultipleValueReturn? an-input)
empty] empty]
[(ControlFrameTemporary? an-input) [(ControlFrameTemporary? an-input)
empty] empty]
[(CompiledProcedureEntry? an-input) [(CompiledProcedureEntry? an-input)
(collect-input (CompiledProcedureEntry-proc an-input))] (collect-input (CompiledProcedureEntry-proc an-input))]
[(CompiledProcedureClosureReference? an-input) [(CompiledProcedureClosureReference? an-input)
(collect-input (CompiledProcedureClosureReference-proc an-input))] (collect-input (CompiledProcedureClosureReference-proc an-input))]
[(PrimitiveKernelValue? an-input) [(PrimitiveKernelValue? an-input)
empty] empty]
[(ModuleEntry? an-input) [(ModuleEntry? an-input)
empty] empty]
[(IsModuleInvoked? an-input) [(IsModuleInvoked? an-input)
empty] empty]
[(IsModuleLinked? an-input) [(IsModuleLinked? an-input)
empty] empty]
[(VariableReference? an-input) [(VariableReference? an-input)
empty])) empty]))
(: collect-location ((U Reg Label) -> (Listof Symbol))) (: collect-location ((U Reg Label) -> (Listof Symbol)))
(define (collect-location a-location) (define (collect-location a-location)
(cond (cond
[(Reg? a-location) [(Reg? a-location)
empty] empty]
[(Label? a-location) [(Label? a-location)
(list (Label-name a-location))])) (list (Label-name a-location))]))
(: collect-primitive-operator (PrimitiveOperator -> (Listof Symbol))) (: collect-primitive-operator (PrimitiveOperator -> (Listof Symbol)))
(define (collect-primitive-operator op) (define (collect-primitive-operator op)
(cond (cond
[(GetCompiledProcedureEntry? op) [(GetCompiledProcedureEntry? op)
empty] empty]
[(MakeCompiledProcedure? op) [(MakeCompiledProcedure? op)
(list (MakeCompiledProcedure-label op))] (list (MakeCompiledProcedure-label op))]
[(MakeCompiledProcedureShell? op) [(MakeCompiledProcedureShell? op)
(list (MakeCompiledProcedureShell-label op))] (list (MakeCompiledProcedureShell-label op))]
[(ApplyPrimitiveProcedure? op) [(ApplyPrimitiveProcedure? op)
empty] empty]
[(CaptureEnvironment? op) [(CaptureEnvironment? op)
empty] empty]
[(CaptureControl? op) [(CaptureControl? op)
empty] empty]
[(MakeBoxedEnvironmentValue? op) [(MakeBoxedEnvironmentValue? op)
empty] empty]
[(CallKernelPrimitiveProcedure? op) [(CallKernelPrimitiveProcedure? op)
empty])) 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-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))) (: label->labels ((U Symbol LinkedLabel) -> (Listof Symbol)))
(define (label->labels label) (define (label->labels label)
(cond (cond
[(symbol? label) [(symbol? label)
(list label)] (list label)]
[(LinkedLabel? label) [(LinkedLabel? label)
(list (LinkedLabel-label label) (list (LinkedLabel-label label)
(LinkedLabel-linked-to label))])) (LinkedLabel-linked-to label))]))

116
js-assembler/fracture.rkt
View File

@ -1,26 +1,30 @@
#lang typed/racket/base #lang typed/racket/base
(require "assemble-structs.rkt" (require "assemble-structs.rkt"
"assemble-helpers.rkt"
"assemble-open-coded.rkt"
"assemble-expression.rkt"
"assemble-perform-statement.rkt"
"collect-jump-targets.rkt" "collect-jump-targets.rkt"
"../compiler/il-structs.rkt" "../compiler/il-structs.rkt"
"../compiler/lexical-structs.rkt"
"../compiler/expression-structs.rkt" "../compiler/expression-structs.rkt"
"../helpers.rkt"
racket/string
racket/list) 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) (provide fracture)
;; fracture: (listof stmt) -> (listof basic-block) ;; fracture: (listof stmt) -> (listof basic-block)
(: fracture ((Listof Statement) -> (Listof BasicBlock))) (: fracture ((Listof Statement) -> (values (Listof BasicBlock)
(Listof Symbol))))
(define (fracture stmts) (define (fracture stmts)
(let*: ([first-block-label : Symbol (if (and (not (empty? stmts)) (let*: ([first-block-label : Symbol (if (and (not (empty? stmts))
(symbol? (first stmts))) (symbol? (first stmts)))
@ -31,48 +35,52 @@
(rest stmts) (rest stmts)
stmts)] stmts)]
[jump-targets : (Listof Symbol) [jump-targets : (Listof Symbol)
(cons first-block-label (collect-general-jump-targets stmts))]) (cons first-block-label (collect-general-jump-targets stmts))]
(let: loop : (Listof BasicBlock) [entry-points : (Listof Symbol)
([name : Symbol first-block-label] (cons first-block-label (collect-entry-points stmts))])
[acc : (Listof UnlabeledStatement) '()]
[basic-blocks : (Listof BasicBlock) '()] (let: loop : (values (Listof BasicBlock) (Listof Symbol))
[stmts : (Listof Statement) stmts] ([name : Symbol first-block-label]
[last-stmt-goto? : Boolean #f]) [acc : (Listof UnlabeledStatement) '()]
(cond [basic-blocks : (Listof BasicBlock) '()]
[(null? stmts) [stmts : (Listof Statement) stmts]
(reverse (cons (make-BasicBlock name (reverse acc)) [last-stmt-goto? : Boolean #f])
basic-blocks))] (cond
[else [(null? stmts)
(let: ([first-stmt : Statement (car stmts)]) (values (reverse (cons (make-BasicBlock name (reverse acc))
(: do-on-label (Symbol -> (Listof BasicBlock))) basic-blocks))
(define (do-on-label label-name) entry-points)]
(cond [else
[(member label-name jump-targets) (let: ([first-stmt : Statement (car stmts)])
(loop label-name (: do-on-label (Symbol -> (values (Listof BasicBlock) (Listof Symbol))))
'() (define (do-on-label label-name)
(cons (make-BasicBlock (cond
name [(member label-name jump-targets)
(if last-stmt-goto? (loop label-name
(reverse acc) '()
(reverse (append `(,(make-GotoStatement (make-Label label-name))) (cons (make-BasicBlock
acc)))) name
basic-blocks) (if last-stmt-goto?
(cdr stmts) (reverse acc)
last-stmt-goto?)] (reverse (append `(,(make-GotoStatement (make-Label label-name)))
[else acc))))
(loop name basic-blocks)
acc (cdr stmts)
basic-blocks last-stmt-goto?)]
(cdr stmts) [else
last-stmt-goto?)])) (loop name
(cond acc
[(symbol? first-stmt) basic-blocks
(do-on-label first-stmt)] (cdr stmts)
[(LinkedLabel? first-stmt) last-stmt-goto?)]))
(do-on-label (LinkedLabel-label first-stmt))] (cond
[else [(symbol? first-stmt)
(loop name (do-on-label first-stmt)]
(cons first-stmt acc) [(LinkedLabel? first-stmt)
basic-blocks (do-on-label (LinkedLabel-label first-stmt))]
(cdr stmts) [else
(GotoStatement? (car stmts)))]))])))) (loop name
(cons first-stmt acc)
basic-blocks
(cdr stmts)
(GotoStatement? (car stmts)))]))]))))