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

I think the definitions in collect-jump-targets is causing typed racket some grief

Browse Source
This commit is contained in:
Danny Yoo 2011-04-18 13:15:01 -04:00
parent 78c7090593
commit 7fb3ae68bf
1 changed files with 1 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

139
assemble.rkt
View File

@ -7,6 +7,7 @@
"assemble-open-coded.rkt" "assemble-open-coded.rkt"
"assemble-expression.rkt" "assemble-expression.rkt"
"assemble-perform-statement.rkt" "assemble-perform-statement.rkt"
"collect-jump-targets.rkt"
racket/string racket/string
racket/list) racket/list)
@ -153,144 +154,6 @@
;; (next)]))])) ;; (next)]))]))
;; ;; collect-general-jump-targets: (listof stmt) -> (listof label)
;; ;; collects all the labels that are potential targets for GOTOs or branches.
;; (: collect-general-jump-targets ((Listof Statement) -> (Listof Symbol)))
;; (define (collect-general-jump-targets 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]))
;; (: 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
;; [(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 (cond
;; [(symbol? stmt)
;; empty]
;; [(LinkedLabel? stmt)
;; (list (LinkedLabel-label stmt)
;; (LinkedLabel-linked-to stmt))]
;; [(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))]
;; [(TestAndBranchStatement? stmt)
;; (list (TestAndBranchStatement-label stmt))]
;; [(GotoStatement? stmt)
;; (collect-location (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])
;; (loop (rest stmts))))]))))
(: 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))]))
;; assemble-basic-block: basic-block -> string ;; assemble-basic-block: basic-block -> string