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

fixing indentation, enabling comments in emitted source

Browse Source
This commit is contained in:
Danny Yoo 2012-02-29 12:37:09 -05:00
parent fc521f6f7b
commit e9d3c207f7
4 changed files with 425 additions and 431 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

258
compiler/compiler.rkt
View File

@ -440,7 +440,7 @@
(append-instruction-sequences (append-instruction-sequences
(make-AssignImmediate 'argcount (make-Const 1)) (make-AssignImmediate 'argcount (make-Const 1))
(make-Perform (make-RaiseContextExpectedValuesError! (make-Perform (make-RaiseContextExpectedValuesError!
context))))]))])) context))))]))]))
@ -453,7 +453,7 @@
cenv cenv
(append-instruction-sequences (append-instruction-sequences
(make-AssignImmediate target (make-Const (make-AssignImmediate target (make-Const
(ensure-const-value (Constant-v exp)))) (ensure-const-value (Constant-v exp))))
singular-context-check)))) singular-context-check))))
@ -476,8 +476,8 @@
cenv cenv
(append-instruction-sequences (append-instruction-sequences
(make-AssignImmediate target (make-AssignImmediate target
(make-EnvLexicalReference (LocalRef-depth exp) (make-EnvLexicalReference (LocalRef-depth exp)
(LocalRef-unbox? exp))) (LocalRef-unbox? exp)))
singular-context-check)))) singular-context-check))))
@ -490,35 +490,35 @@
(end-with-linkage linkage (end-with-linkage linkage
cenv cenv
(append-instruction-sequences (append-instruction-sequences
;; If it's a module variable, we need to look there. ;; If it's a module variable, we need to look there.
(cond (cond
[(ModuleVariable? prefix-element) [(ModuleVariable? prefix-element)
(cond [(kernel-module-name? (ModuleVariable-module-name prefix-element)) (cond [(kernel-module-name? (ModuleVariable-module-name prefix-element))
(make-AssignPrimOp target (make-AssignPrimOp target
(make-PrimitivesReference (make-PrimitivesReference
(kernel-module-variable->primitive-name (kernel-module-variable->primitive-name
prefix-element) prefix-element)
))] ))]
[else [else
(make-AssignImmediate (make-AssignImmediate
target target
(make-EnvPrefixReference (ToplevelRef-depth exp) (make-EnvPrefixReference (ToplevelRef-depth exp)
(ToplevelRef-pos exp) (ToplevelRef-pos exp)
#t))])] #t))])]
[else [else
(append-instruction-sequences (append-instruction-sequences
(if (ToplevelRef-check-defined? exp) (if (ToplevelRef-check-defined? exp)
(make-Perform (make-CheckToplevelBound! (make-Perform (make-CheckToplevelBound!
(ToplevelRef-depth exp) (ToplevelRef-depth exp)
(ToplevelRef-pos exp))) (ToplevelRef-pos exp)))
empty-instruction-sequence) empty-instruction-sequence)
(make-AssignImmediate (make-AssignImmediate
target target
(make-EnvPrefixReference (ToplevelRef-depth exp) (make-EnvPrefixReference (ToplevelRef-depth exp)
(ToplevelRef-pos exp) (ToplevelRef-pos exp)
#f)))]) #f)))])
singular-context-check)))) singular-context-check))))
@ -532,20 +532,20 @@
(define prefix-element (list-ref (Prefix-names prefix) (ToplevelSet-pos exp))) (define prefix-element (list-ref (Prefix-names prefix) (ToplevelSet-pos exp)))
(let ([get-value-code (let ([get-value-code
(cond (cond
[(ModuleVariable? prefix-element) [(ModuleVariable? prefix-element)
(compile (ToplevelSet-value exp) (compile (ToplevelSet-value exp)
cenv cenv
(make-EnvPrefixReference (ToplevelSet-depth exp) (make-EnvPrefixReference (ToplevelSet-depth exp)
(ToplevelSet-pos exp) (ToplevelSet-pos exp)
#t) #t)
next-linkage/expects-single)] next-linkage/expects-single)]
[else [else
(compile (ToplevelSet-value exp) (compile (ToplevelSet-value exp)
cenv cenv
(make-EnvPrefixReference (ToplevelSet-depth exp) (make-EnvPrefixReference (ToplevelSet-depth exp)
(ToplevelSet-pos exp) (ToplevelSet-pos exp)
#f) #f)
next-linkage/expects-single)])] next-linkage/expects-single)])]
[singular-context-check (emit-singular-context linkage)]) [singular-context-check (emit-singular-context linkage)])
(end-with-linkage (end-with-linkage
linkage linkage
@ -576,7 +576,7 @@
(append-instruction-sequences (append-instruction-sequences
p-code p-code
(make-TestAndJump (make-TestFalse (make-Reg 'val)) (make-TestAndJump (make-TestFalse (make-Reg 'val))
f-branch:) f-branch:)
c-code c-code
f-branch: a-code f-branch: a-code
(if (NextLinkage? linkage) (if (NextLinkage? linkage)
@ -648,7 +648,6 @@
(let ([evaluate-and-save-first-expression (let ([evaluate-and-save-first-expression
(let ([after-first-seq (make-label 'afterFirstSeqEvaluated)]) (let ([after-first-seq (make-label 'afterFirstSeqEvaluated)])
(append-instruction-sequences (append-instruction-sequences
(make-Comment "begin0")
;; Evaluate the first expression in a multiple-value context, and get the values on the stack. ;; Evaluate the first expression in a multiple-value context, and get the values on the stack.
(compile (first seq) cenv 'val next-linkage/keep-multiple-on-stack) (compile (first seq) cenv 'val next-linkage/keep-multiple-on-stack)
@ -659,10 +658,10 @@
;; Next, we save those values temporarily in a throwaway control frame. ;; Next, we save those values temporarily in a throwaway control frame.
(make-PushControlFrame/Generic) (make-PushControlFrame/Generic)
(make-AssignImmediate (make-ControlFrameTemporary 'pendingBegin0Count) (make-AssignImmediate (make-ControlFrameTemporary 'pendingBegin0Count)
(make-Reg 'argcount)) (make-Reg 'argcount))
(make-Perform (make-UnspliceRestFromStack! (make-Const 0) (make-Reg 'argcount))) (make-Perform (make-UnspliceRestFromStack! (make-Const 0) (make-Reg 'argcount)))
(make-AssignImmediate (make-ControlFrameTemporary 'pendingBegin0Values) (make-AssignImmediate (make-ControlFrameTemporary 'pendingBegin0Values)
(make-EnvLexicalReference 0 #f)) (make-EnvLexicalReference 0 #f))
(make-PopEnvironment (make-Const 1) (make-Const 0))))] (make-PopEnvironment (make-Const 1) (make-Const 0))))]
[reinstate-values-on-stack [reinstate-values-on-stack
@ -764,7 +763,6 @@
(append-instruction-sequences (append-instruction-sequences
;; Make some temporary space for the lambdas ;; Make some temporary space for the lambdas
(make-Comment "scratch space for case-lambda")
(make-PushEnvironment n #f) (make-PushEnvironment n #f)
;; Compile each of the lambdas ;; Compile each of the lambdas
@ -870,36 +868,44 @@
singular-context-check)))) singular-context-check))))
;; We keep track of which lambda is currently being compiled for potential optimizations
;; e.g. self tail calls.
(: current-lambda-body-being-compiled (Parameterof (U #f Lam)))
(define current-lambda-body-being-compiled (make-parameter #f))
(: compile-lambda-body (Lam CompileTimeEnvironment -> InstructionSequence)) (: compile-lambda-body (Lam CompileTimeEnvironment -> InstructionSequence))
;; Compiles the body of the lambda in the appropriate environment. ;; Compiles the body of the lambda in the appropriate environment.
;; Closures will target their value to the 'val register, and use return linkage. ;; Closures will target their value to the 'val register, and use return linkage.
(define (compile-lambda-body exp cenv) (define (compile-lambda-body exp cenv)
(let: ([maybe-unsplice-rest-argument : InstructionSequence (parameterize ([current-lambda-body-being-compiled exp])
(if (Lam-rest? exp) (let: ([maybe-unsplice-rest-argument : InstructionSequence
(make-Perform (if (Lam-rest? exp)
(make-UnspliceRestFromStack! (make-Perform
(make-Const (Lam-num-parameters exp)) (make-UnspliceRestFromStack!
(new-SubtractArg (make-Reg 'argcount) (make-Const (Lam-num-parameters exp))
(make-Const (Lam-num-parameters exp))))) (new-SubtractArg (make-Reg 'argcount)
empty-instruction-sequence)] (make-Const (Lam-num-parameters exp)))))
[maybe-install-closure-values : InstructionSequence empty-instruction-sequence)]
(if (not (empty? (Lam-closure-map exp))) [maybe-install-closure-values : InstructionSequence
(append-instruction-sequences (if (not (empty? (Lam-closure-map exp)))
(make-Comment (format "installing closure for ~s" (Lam-name exp))) (append-instruction-sequences
(make-Perform (make-InstallClosureValues! (make-Perform (make-InstallClosureValues!
(length (Lam-closure-map exp))))) (length (Lam-closure-map exp)))))
empty-instruction-sequence)] empty-instruction-sequence)]
[lam-body-code : InstructionSequence [lam-body-code : InstructionSequence
(compile (Lam-body exp) (compile (Lam-body exp)
(extract-lambda-cenv exp cenv) (extract-lambda-cenv exp cenv)
'val 'val
return-linkage)]) return-linkage)])
(append-instruction-sequences (append-instruction-sequences
(Lam-entry-label exp) (Lam-entry-label exp)
maybe-unsplice-rest-argument (Comment (format "lambda body for ~a" (Lam-name exp)))
maybe-install-closure-values maybe-unsplice-rest-argument
lam-body-code))) maybe-install-closure-values
lam-body-code))))
(: compile-case-lambda-body (CaseLam CompileTimeEnvironment -> InstructionSequence)) (: compile-case-lambda-body (CaseLam CompileTimeEnvironment -> InstructionSequence))
@ -914,21 +920,21 @@
(let ([not-match (make-label 'notMatch)]) (let ([not-match (make-label 'notMatch)])
(append-instruction-sequences (append-instruction-sequences
(make-TestAndJump (make-TestClosureArityMismatch (make-TestAndJump (make-TestClosureArityMismatch
(make-CompiledProcedureClosureReference (make-CompiledProcedureClosureReference
(make-Reg 'proc) (make-Reg 'proc)
i) i)
(make-Reg 'argcount)) (make-Reg 'argcount))
not-match) not-match)
;; Set the procedure register to the lam ;; Set the procedure register to the lam
(make-AssignImmediate (make-AssignImmediate
'proc 'proc
(make-CompiledProcedureClosureReference (make-Reg 'proc) i)) (make-CompiledProcedureClosureReference (make-Reg 'proc) i))
(make-Goto (make-Label (make-Goto (make-Label
(cond [(Lam? lam) (cond [(Lam? lam)
(Lam-entry-label lam)] (Lam-entry-label lam)]
[(EmptyClosureReference? lam) [(EmptyClosureReference? lam)
(EmptyClosureReference-entry-label lam)]))) (EmptyClosureReference-entry-label lam)])))
not-match))) not-match)))
(CaseLam-clauses exp) (CaseLam-clauses exp)
@ -980,7 +986,7 @@
(define (default) (define (default)
(compile-general-application exp cenv target linkage)) (compile-general-application exp cenv target linkage))
(let: ([op-knowledge : CompileTimeEnvironmentEntry (let: ([op-knowledge : CompileTimeEnvironmentEntry
(extract-static-knowledge (App-operator exp) (extract-static-knowledge (App-operator exp)
extended-cenv)]) extended-cenv)])
@ -1027,8 +1033,8 @@
(: 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)
@ -1058,12 +1064,11 @@
'val))))]) 'val))))])
(append-instruction-sequences (append-instruction-sequences
(make-Comment "scratch space for general application")
(make-PushEnvironment (length (App-operands exp)) #f) (make-PushEnvironment (length (App-operands exp)) #f)
proc-code proc-code
(juggle-operands operand-codes) (juggle-operands operand-codes)
(make-AssignImmediate 'argcount (make-AssignImmediate 'argcount
(make-Const (length (App-operands exp)))) (make-Const (length (App-operands exp))))
(compile-general-procedure-call cenv (compile-general-procedure-call cenv
(make-Const (length (App-operands exp))) (make-Const (length (App-operands exp)))
target target
@ -1143,11 +1148,11 @@
(make-EnvLexicalReference i #f))))) (make-EnvLexicalReference i #f)))))
(make-AssignImmediate 'proc (make-PrimitiveKernelValue kernel-op)) (make-AssignImmediate 'proc (make-PrimitiveKernelValue kernel-op))
(make-AssignImmediate 'argcount (make-AssignImmediate 'argcount
(make-Const (length (App-operands exp)))) (make-Const (length (App-operands exp))))
(make-Perform (make-RaiseArityMismatchError! (make-Perform (make-RaiseArityMismatchError!
(make-Reg 'proc) (make-Reg 'proc)
expected-arity expected-arity
(make-Const n)))))) (make-Const n))))))
(cond (cond
[(IncorrectArity? expected-operand-types) [(IncorrectArity? expected-operand-types)
@ -1190,11 +1195,11 @@
linkage cenv linkage cenv
(append-instruction-sequences (append-instruction-sequences
(make-AssignPrimOp target (make-AssignPrimOp target
(make-CallKernelPrimitiveProcedure (make-CallKernelPrimitiveProcedure
kernel-op kernel-op
operand-poss operand-poss
expected-operand-types expected-operand-types
typechecks?)) typechecks?))
singular-context-check)))] singular-context-check)))]
[else [else
@ -1224,9 +1229,9 @@
rest-operands))] rest-operands))]
[(constant-operand-knowledge) [(constant-operand-knowledge)
(map (lambda: ([arg : Expression]) (map (lambda: ([arg : Expression])
(extract-static-knowledge arg extended-cenv)) (extract-static-knowledge arg extended-cenv))
constant-operands)] constant-operands)]
[(operand-knowledge) [(operand-knowledge)
(append constant-operand-knowledge (append constant-operand-knowledge
(map (lambda: ([arg : Expression]) (map (lambda: ([arg : Expression])
@ -1304,11 +1309,11 @@
(LocalRef-unbox? e))] (LocalRef-unbox? e))]
[(ToplevelRef? e) [(ToplevelRef? e)
(cond (cond
[(ModuleVariable? k) [(ModuleVariable? k)
(make-EnvPrefixReference (ToplevelRef-depth e) (ToplevelRef-pos e) #t)] (make-EnvPrefixReference (ToplevelRef-depth e) (ToplevelRef-pos e) #t)]
[else [else
(make-EnvPrefixReference (ToplevelRef-depth e) (ToplevelRef-pos e) #f)])] (make-EnvPrefixReference (ToplevelRef-depth e) (ToplevelRef-pos e) #f)])]
[else [else
(error 'all-operands-are-constant "Impossible")])) (error 'all-operands-are-constant "Impossible")]))
rands rands
@ -1428,7 +1433,6 @@
'proc 'proc
next-linkage/expects-single)]) next-linkage/expects-single)])
(append-instruction-sequences (append-instruction-sequences
(make-Comment "scratch space for statically known lambda application")
(make-PushEnvironment (length (App-operands exp)) #f) (make-PushEnvironment (length (App-operands exp)) #f)
(apply append-instruction-sequences operand-codes) (apply append-instruction-sequences operand-codes)
proc-code proc-code
@ -1458,9 +1462,9 @@
(append-instruction-sequences (append-instruction-sequences
(car ops) (car ops)
(make-AssignImmediate 'proc (make-AssignImmediate 'proc
(make-EnvLexicalReference n #f)) (make-EnvLexicalReference n #f))
(make-AssignImmediate (make-EnvLexicalReference n #f) (make-AssignImmediate (make-EnvLexicalReference n #f)
(make-Reg 'val))))] (make-Reg 'val))))]
[else [else
;; Otherwise, add instructions to juggle the operator and operands in the stack. ;; Otherwise, add instructions to juggle the operator and operands in the stack.
(append-instruction-sequences (car ops) (append-instruction-sequences (car ops)
@ -1526,7 +1530,7 @@
empty-instruction-sequence empty-instruction-sequence
(make-AssignImmediate target (make-Reg 'val))) (make-AssignImmediate target (make-Reg 'val)))
(emit-singular-context linkage)))) (emit-singular-context linkage))))
@ -1544,7 +1548,7 @@
(linkage-context linkage)))]) (linkage-context linkage)))])
(append-instruction-sequences (append-instruction-sequences
(make-AssignImmediate 'argcount (make-AssignImmediate 'argcount
(make-Const n)) (make-Const n))
(compile-compiled-procedure-application cenv (compile-compiled-procedure-application cenv
(make-Const n) (make-Const n)
(make-Label (make-Label
@ -1685,8 +1689,8 @@
on-return/multiple on-return/multiple
;; if the wrong number of arguments come in, die ;; if the wrong number of arguments come in, die
(make-TestAndJump (make-TestZero (new-SubtractArg (make-Reg 'argcount) (make-TestAndJump (make-TestZero (new-SubtractArg (make-Reg 'argcount)
(make-Const context))) (make-Const context)))
after-value-check) after-value-check)
on-return on-return
(make-Perform (make-Perform
(make-RaiseContextExpectedValuesError! context)) (make-RaiseContextExpectedValuesError! context))
@ -1776,7 +1780,7 @@
(make-LabelLinkage after-body-code (linkage-context linkage))])] (make-LabelLinkage after-body-code (linkage-context linkage))])]
[(LabelLinkage? linkage) [(LabelLinkage? linkage)
(make-LabelLinkage after-body-code (LabelLinkage-context linkage))])] (make-LabelLinkage after-body-code (LabelLinkage-context linkage))])]
[body-target : Target (adjust-target-depth target 1)] [body-target : Target (adjust-target-depth target 1)]
[body-code : InstructionSequence [body-code : InstructionSequence
(compile (Let1-body exp) extended-cenv body-target let-linkage)]) (compile (Let1-body exp) extended-cenv body-target let-linkage)])
@ -1784,12 +1788,11 @@
linkage linkage
extended-cenv extended-cenv
(append-instruction-sequences (append-instruction-sequences
(make-Comment "scratch space for let1")
(make-PushEnvironment 1 #f) (make-PushEnvironment 1 #f)
rhs-code rhs-code
body-code body-code
after-body-code after-body-code
;; We want to clear out the scratch space introduced by the ;; We want to clear out the scratch space introduced by the
;; let1. However, there may be multiple values coming ;; let1. However, there may be multiple values coming
@ -1805,7 +1808,7 @@
[(eq? context 'keep-multiple) [(eq? context 'keep-multiple)
;; dynamic number of arguments that need ;; dynamic number of arguments that need
;; to be preserved ;; to be preserved
(make-PopEnvironment (make-Const 1) (make-PopEnvironment (make-Const 1)
(new-SubtractArg (new-SubtractArg
(make-Reg 'argcount) (make-Reg 'argcount)
@ -1859,7 +1862,6 @@
linkage linkage
extended-cenv extended-cenv
(append-instruction-sequences (append-instruction-sequences
(make-Comment "scratch space for let-void")
(make-PushEnvironment n (LetVoid-boxes? exp)) (make-PushEnvironment n (LetVoid-boxes? exp))
body-code body-code
after-body-code after-body-code
@ -1952,9 +1954,8 @@
(map (lambda: ([lam : Lam] (map (lambda: ([lam : Lam]
[i : Natural]) [i : Natural])
(append-instruction-sequences (append-instruction-sequences
(make-Comment (format "Installing shell for ~s\n" (Lam-name lam)))
(make-Perform (make-FixClosureShellMap! i (make-Perform (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))))
@ -1968,7 +1969,6 @@
(: compile-install-value (InstallValue CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-install-value (InstallValue CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-install-value exp cenv target linkage) (define (compile-install-value exp cenv target linkage)
(append-instruction-sequences (append-instruction-sequences
(make-Comment "install-value")
(let ([count (InstallValue-count exp)]) (let ([count (InstallValue-count exp)])
(cond [(= count 0) (cond [(= count 0)
(end-with-linkage (end-with-linkage
@ -1980,8 +1980,6 @@
(make-NextLinkage 0)))] (make-NextLinkage 0)))]
[(= count 1) [(= count 1)
(append-instruction-sequences (append-instruction-sequences
(make-Comment (format "installing single value into ~s"
(InstallValue-depth exp)))
(end-with-linkage (end-with-linkage
linkage linkage
cenv cenv
@ -1994,7 +1992,6 @@
linkage linkage
cenv cenv
(append-instruction-sequences (append-instruction-sequences
(make-Comment "install-value: evaluating values")
(compile (InstallValue-body exp) (compile (InstallValue-body exp)
cenv cenv
'val 'val
@ -2003,7 +2000,6 @@
(map (lambda: ([to : EnvLexicalReference] (map (lambda: ([to : EnvLexicalReference]
[from : OpArg]) [from : OpArg])
(append-instruction-sequences (append-instruction-sequences
(make-Comment "install-value: installing value")
(make-AssignImmediate to from))) (make-AssignImmediate to from)))
(build-list count (lambda: ([i : Natural]) (build-list count (lambda: ([i : Natural])
(make-EnvLexicalReference (+ i (make-EnvLexicalReference (+ i
@ -2021,7 +2017,7 @@
(define (compile-box-environment-value exp cenv target linkage) (define (compile-box-environment-value exp cenv target linkage)
(append-instruction-sequences (append-instruction-sequences
(make-AssignPrimOp (make-EnvLexicalReference (BoxEnv-depth exp) #f) (make-AssignPrimOp (make-EnvLexicalReference (BoxEnv-depth exp) #f)
(make-MakeBoxedEnvironmentValue (BoxEnv-depth exp))) (make-MakeBoxedEnvironmentValue (BoxEnv-depth exp)))
(compile (BoxEnv-body exp) cenv target linkage))) (compile (BoxEnv-body exp) cenv target linkage)))
@ -2051,15 +2047,15 @@
context on-return/multiple: on-return:)] context on-return/multiple: on-return:)]
[maybe-migrate-val-to-target [maybe-migrate-val-to-target
(cond (cond
[(eq? target 'val) [(eq? target 'val)
empty-instruction-sequence] empty-instruction-sequence]
[else [else
(make-AssignImmediate target (make-Reg 'val))])]) (make-AssignImmediate target (make-Reg 'val))])])
(append-instruction-sequences (append-instruction-sequences
(make-PushControlFrame/Call on-return:) (make-PushControlFrame/Call on-return:)
(compile (WithContMark-key exp) cenv 'val next-linkage/expects-single) (compile (WithContMark-key exp) cenv 'val next-linkage/expects-single)
(make-AssignImmediate (make-ControlFrameTemporary 'pendingContinuationMarkKey) (make-AssignImmediate (make-ControlFrameTemporary 'pendingContinuationMarkKey)
(make-Reg 'val)) (make-Reg 'val))
(compile (WithContMark-value exp) cenv 'val next-linkage/expects-single) (compile (WithContMark-value exp) cenv 'val next-linkage/expects-single)
(make-Perform (make-InstallContinuationMarkEntry!)) (make-Perform (make-InstallContinuationMarkEntry!))
(compile (WithContMark-body exp) cenv 'val return-linkage/nontail) (compile (WithContMark-body exp) cenv 'val return-linkage/nontail)

6
compiler/optimize-il.rkt
View File

@ -193,8 +193,8 @@
] ]
[(Comment? a-stmt) [(Comment? a-stmt)
(loop (rest stmts)) ;(loop (rest stmts))
;(cons a-stmt (loop (rest stmts))) (cons a-stmt (loop (rest stmts)))
] ]
[(AssignImmediate? a-stmt) [(AssignImmediate? a-stmt)
@ -386,7 +386,7 @@
[(PopControlFrame? stmt) [(PopControlFrame? stmt)
#f] #f]
[(Comment? stmt) [(Comment? stmt)
#t])) #f]))

590
js-assembler/assemble.rkt
View File

@ -13,8 +13,7 @@
"../sets.rkt" "../sets.rkt"
"../helpers.rkt" "../helpers.rkt"
racket/string racket/string
racket/list racket/list)
racket/match)
(require/typed "../logger.rkt" (require/typed "../logger.rkt"
[log-debug (String -> Void)]) [log-debug (String -> Void)])
@ -26,7 +25,7 @@
;; 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 emit-debug-trace? #f)
@ -42,16 +41,16 @@
(display "var RT = plt.runtime;\n" op) (display "var RT = plt.runtime;\n" op)
(define-values (basic-blocks entry-points) (fracture stmts)) (define-values (basic-blocks entry-points) (fracture stmts))
(define function-entry-and-exit-names (define function-entry-and-exit-names
(list->set (get-function-entry-and-exit-names stmts))) (list->set (get-function-entry-and-exit-names stmts)))
(: blockht : Blockht) (: blockht : Blockht)
(define blockht (make-hash)) (define blockht (make-hash))
(for ([b basic-blocks]) (for ([b basic-blocks])
(hash-set! blockht (BasicBlock-name b) b)) (hash-set! blockht (BasicBlock-name b) b))
(write-blocks basic-blocks (write-blocks basic-blocks
blockht blockht
(list->set entry-points) (list->set entry-points)
@ -69,7 +68,7 @@ for (param in params) {
} }
} }
EOF EOF
op) op)
(fprintf op "M.trampoline(~a, true); })" (fprintf op "M.trampoline(~a, true); })"
(assemble-label (make-Label (BasicBlock-name (first basic-blocks))) (assemble-label (make-Label (BasicBlock-name (first basic-blocks)))
blockht))) blockht)))
@ -83,7 +82,7 @@ EOF
;; Since there may be cycles between the blocks, we cut the cycles by ;; Since there may be cycles between the blocks, we cut the cycles by
;; making them entry points as well. ;; making them entry points as well.
(insert-cycles-as-entry-points! entry-points blockht) (insert-cycles-as-entry-points! entry-points blockht)
(set-for-each (lambda: ([s : Symbol]) (set-for-each (lambda: ([s : Symbol])
(log-debug (format "Emitting code for basic block ~s" s)) (log-debug (format "Emitting code for basic block ~s" s))
(assemble-basic-block (hash-ref blockht s) (assemble-basic-block (hash-ref blockht s)
@ -111,15 +110,15 @@ EOF
(cond (cond
[(set-contains? visited next-to-visit) [(set-contains? visited next-to-visit)
#;(unless (set-contains? entry-points next-to-visit) #;(unless (set-contains? entry-points next-to-visit)
(log-debug (format "Promoting ~a to an entry point" next-to-visit)) (log-debug (format "Promoting ~a to an entry point" next-to-visit))
(set-insert! entry-points next-to-visit)) (set-insert! entry-points next-to-visit))
(loop (rest queue))] (loop (rest queue))]
[else [else
(set-insert! visited next-to-visit) (set-insert! visited next-to-visit)
(set-insert! entry-points next-to-visit) (set-insert! entry-points next-to-visit)
(loop (list-union (basic-block-out-edges (hash-ref blockht next-to-visit)) (loop (list-union (basic-block-out-edges (hash-ref blockht next-to-visit))
(rest queue)))])])) (rest queue)))])]))
(loop (set->list entry-points))) (loop (set->list entry-points)))
@ -146,19 +145,19 @@ EOF
;; that if .mvr is missing, that the block only expects one. ;; that if .mvr is missing, that the block only expects one.
(define linked-to-block (hash-ref blockht (LinkedLabel-linked-to stmt))) (define linked-to-block (hash-ref blockht (LinkedLabel-linked-to stmt)))
(cond (cond
[(block-looks-like-context-expected-values? linked-to-block) [(block-looks-like-context-expected-values? linked-to-block)
=> (lambda (expected) => (lambda (expected)
(cond (cond
[(= expected 1) [(= expected 1)
(void)] (void)]
[else [else
(fprintf op "~a.mvr=RT.si_context_expected(~a);\n" (fprintf op "~a.mvr=RT.si_context_expected(~a);\n"
(munge-label-name (make-Label (LinkedLabel-label stmt))) (munge-label-name (make-Label (LinkedLabel-label stmt)))
expected)]))] expected)]))]
[else [else
(fprintf op "~a.mvr=~a;\n" (fprintf op "~a.mvr=~a;\n"
(munge-label-name (make-Label (LinkedLabel-label stmt))) (munge-label-name (make-Label (LinkedLabel-label stmt)))
(assemble-label (make-Label (LinkedLabel-linked-to stmt)) blockht))]) (assemble-label (make-Label (LinkedLabel-linked-to stmt)) blockht))])
(next)] (next)]
[(DebugPrint? stmt) [(DebugPrint? stmt)
(next)] (next)]
@ -197,26 +196,26 @@ EOF
(: assemble-basic-block (BasicBlock Blockht (Setof Symbol) (Setof Symbol) Output-Port -> 'ok)) (: assemble-basic-block (BasicBlock Blockht (Setof Symbol) (Setof Symbol) Output-Port -> 'ok))
(define (assemble-basic-block a-basic-block blockht entry-points function-entry-and-exit-names op) (define (assemble-basic-block a-basic-block blockht entry-points function-entry-and-exit-names op)
(cond (cond
[(block-looks-like-context-expected-values? a-basic-block) [(block-looks-like-context-expected-values? a-basic-block)
=> =>
(lambda (expected) (lambda (expected)
(cond (cond
[(= expected 1) [(= expected 1)
'ok] 'ok]
[else [else
(fprintf op "~a=RT.si_context_expected(~a);\n" (fprintf op "~a=RT.si_context_expected(~a);\n"
(munge-label-name (make-Label (BasicBlock-name a-basic-block))) (munge-label-name (make-Label (BasicBlock-name a-basic-block)))
expected) expected)
'ok]))] 'ok]))]
[(block-looks-like-pop-multiple-values-and-continue? a-basic-block) [(block-looks-like-pop-multiple-values-and-continue? a-basic-block)
=> =>
(lambda (target) (lambda (target)
(fprintf op "~a=RT.si_pop_multiple-values-and-continue(~a);" (fprintf op "~a=RT.si_pop_multiple-values-and-continue(~a);"
(munge-label-name (make-Label (BasicBlock-name a-basic-block))) (munge-label-name (make-Label (BasicBlock-name a-basic-block)))
target))] target))]
[else [else
(default-assemble-basic-block a-basic-block blockht entry-points function-entry-and-exit-names op)])) (default-assemble-basic-block a-basic-block blockht entry-points function-entry-and-exit-names op)]))
@ -230,33 +229,33 @@ EOF
(define last-stmt (define last-stmt
(last (BasicBlock-stmts a-basic-block))) (last (BasicBlock-stmts a-basic-block)))
(cond (cond
[(Goto? last-stmt) [(Goto? last-stmt)
(define target (Goto-target last-stmt)) (define target (Goto-target last-stmt))
(equal? target (make-Label (BasicBlock-name a-basic-block)))] (equal? target (make-Label (BasicBlock-name a-basic-block)))]
[else #f])] [else #f])]
[else #f]))) [else #f])))
(cond (cond
[is-self-looping? [is-self-looping?
(fprintf op "while(true){") (fprintf op "while(true){")
(when (set-contains? function-entry-and-exit-names (BasicBlock-name a-basic-block)) (when (set-contains? function-entry-and-exit-names (BasicBlock-name a-basic-block))
(fprintf op "if(--M.cbt<0){throw ~a;}\n" (fprintf op "if(--M.cbt<0){throw ~a;}\n"
(assemble-label (make-Label (BasicBlock-name a-basic-block)) blockht))) (assemble-label (make-Label (BasicBlock-name a-basic-block)) blockht)))
(assemble-block-statements (BasicBlock-name a-basic-block) (assemble-block-statements (BasicBlock-name a-basic-block)
(drop-right (BasicBlock-stmts a-basic-block) 1) (drop-right (BasicBlock-stmts a-basic-block) 1)
blockht blockht
entry-points entry-points
op) op)
(fprintf op "}")] (fprintf op "}")]
[else [else
(when (set-contains? function-entry-and-exit-names (BasicBlock-name a-basic-block)) (when (set-contains? function-entry-and-exit-names (BasicBlock-name a-basic-block))
(fprintf op "if(--M.cbt<0){throw ~a;}\n" (fprintf op "if(--M.cbt<0){throw ~a;}\n"
(assemble-label (make-Label (BasicBlock-name a-basic-block)) blockht))) (assemble-label (make-Label (BasicBlock-name a-basic-block)) blockht)))
(assemble-block-statements (BasicBlock-name a-basic-block) (assemble-block-statements (BasicBlock-name a-basic-block)
(BasicBlock-stmts a-basic-block) (BasicBlock-stmts a-basic-block)
blockht blockht
entry-points entry-points
op)]) op)])
(display "};\n" op) (display "};\n" op)
'ok) 'ok)
@ -271,7 +270,7 @@ EOF
;(when (and (empty? (rest stmts)) ;(when (and (empty? (rest stmts))
; (not (Goto? stmt))) ; (not (Goto? stmt)))
; (log-debug (format "Last statement of the block ~a is not a goto" name))) ; (log-debug (format "Last statement of the block ~a is not a goto" name)))
(display (assemble-statement stmt blockht) op) (display (assemble-statement stmt blockht) op)
(newline op) (newline op)
(assemble-block-statements name (assemble-block-statements name
@ -318,67 +317,67 @@ EOF
(format "if(~a===0)" (format "if(~a===0)"
(assemble-oparg (TestZero-operand test) (assemble-oparg (TestZero-operand test)
blockht))] blockht))]
[(TestClosureArityMismatch? test) [(TestClosureArityMismatch? test)
(format "if(!RT.isArityMatching((~a).racketArity,~a))" (format "if(!RT.isArityMatching((~a).racketArity,~a))"
(assemble-oparg (TestClosureArityMismatch-closure test) (assemble-oparg (TestClosureArityMismatch-closure test)
blockht) blockht)
(assemble-oparg (TestClosureArityMismatch-n test) (assemble-oparg (TestClosureArityMismatch-n test)
blockht))])) blockht))]))
(display test-code op) (display test-code op)
(display "{" op) (display "{" op)
(cond (cond
[(set-contains? entry-points (TestAndJump-label stmt)) [(set-contains? entry-points (TestAndJump-label stmt))
(display (assemble-jump (make-Label (TestAndJump-label stmt)) (display (assemble-jump (make-Label (TestAndJump-label stmt))
blockht) op)] blockht) op)]
[else [else
(assemble-block-statements (BasicBlock-name (assemble-block-statements (BasicBlock-name
(hash-ref blockht (TestAndJump-label stmt))) (hash-ref blockht (TestAndJump-label stmt)))
(BasicBlock-stmts (BasicBlock-stmts
(hash-ref blockht (TestAndJump-label stmt))) (hash-ref blockht (TestAndJump-label stmt)))
blockht blockht
entry-points entry-points
op)]) op)])
(display "}else{" op) (display "}else{" op)
(assemble-block-statements name (rest stmts) blockht entry-points op) (assemble-block-statements name (rest stmts) blockht entry-points op)
(display "}" op) (display "}" op)
'ok] 'ok]
[(Goto? stmt) [(Goto? stmt)
(let loop ([stmt stmt]) (let loop ([stmt stmt])
(define target (Goto-target stmt)) (define target (Goto-target stmt))
(cond (cond
[(Label? target) [(Label? target)
(define target-block (hash-ref blockht (Label-name target))) (define target-block (hash-ref blockht (Label-name target)))
(define target-name (BasicBlock-name target-block)) (define target-name (BasicBlock-name target-block))
(define target-statements (BasicBlock-stmts target-block)) (define target-statements (BasicBlock-stmts target-block))
(cond (cond
;; Optimization: if the target block consists of a single goto, ;; Optimization: if the target block consists of a single goto,
;; inline and follow the goto. ;; inline and follow the goto.
[(and (not (empty? target-statements)) [(and (not (empty? target-statements))
(= 1 (length target-statements)) (= 1 (length target-statements))
(Goto? (first target-statements))) (Goto? (first target-statements)))
(loop (first target-statements))] (loop (first target-statements))]
[(set-contains? entry-points (Label-name target)) [(set-contains? entry-points (Label-name target))
(display (assemble-statement stmt blockht) op) (display (assemble-statement stmt blockht) op)
'ok] 'ok]
[else [else
(log-debug (format "Assembling inlined jump into ~a" (Label-name target)) ) (log-debug (format "Assembling inlined jump into ~a" (Label-name target)) )
(assemble-block-statements target-name (assemble-block-statements target-name
target-statements target-statements
blockht blockht
entry-points entry-points
op)])] op)])]
[(Reg? target) [(Reg? target)
(display (assemble-statement stmt blockht) op) (display (assemble-statement stmt blockht) op)
'ok] 'ok]
[(ModuleEntry? target) [(ModuleEntry? target)
(display (assemble-statement stmt blockht) op) (display (assemble-statement stmt blockht) op)
'ok] 'ok]
[(CompiledProcedureEntry? target) [(CompiledProcedureEntry? target)
(display (assemble-statement stmt blockht) op) (display (assemble-statement stmt blockht) op)
'ok]))] 'ok]))]
[(PushControlFrame/Generic? stmt) [(PushControlFrame/Generic? stmt)
(default stmt)] (default stmt)]
@ -488,163 +487,162 @@ EOF
(define (assemble-statement stmt blockht) (define (assemble-statement stmt blockht)
(define assembled (define assembled
(cond (cond
[(DebugPrint? stmt) [(DebugPrint? stmt)
(format "M.params.currentOutputPort.writeDomNode(M, $('<span/>').text(~a));" (format "M.params.currentOutputPort.writeDomNode(M, $('<span/>').text(~a));"
(assemble-oparg (DebugPrint-value stmt) (assemble-oparg (DebugPrint-value stmt)
blockht))]
[(AssignImmediate? stmt)
(let: ([t : (String -> String) (assemble-target (AssignImmediate-target stmt))]
[v : OpArg (AssignImmediate-value stmt)])
(t (assemble-oparg v blockht)))]
[(AssignPrimOp? stmt)
((assemble-target (AssignPrimOp-target stmt))
(assemble-op-expression (AssignPrimOp-op stmt)
blockht))] blockht))]
[(AssignImmediate? stmt)
[(Perform? stmt) (let: ([t : (String -> String) (assemble-target (AssignImmediate-target stmt))]
(assemble-op-statement (Perform-op stmt) blockht)] [v : OpArg (AssignImmediate-value stmt)])
(t (assemble-oparg v blockht)))]
[(TestAndJump? stmt)
(let*: ([test : PrimitiveTest (TestAndJump-op stmt)] [(AssignPrimOp? stmt)
[jump : String (assemble-jump ((assemble-target (AssignPrimOp-target stmt))
(make-Label (TestAndJump-label stmt)) (assemble-op-expression (AssignPrimOp-op stmt)
blockht)]) blockht))]
;; to help localize type checks, we add a type annotation here.
(ann (cond [(Perform? stmt)
[(TestFalse? test) (assemble-op-statement (Perform-op stmt) blockht)]
(format "if(~a===false){~a}"
(assemble-oparg (TestFalse-operand test) [(TestAndJump? stmt)
blockht) (let*: ([test : PrimitiveTest (TestAndJump-op stmt)]
jump)] [jump : String (assemble-jump
[(TestTrue? test) (make-Label (TestAndJump-label stmt))
(format "if(~a!==false){~a}" blockht)])
(assemble-oparg (TestTrue-operand test) ;; to help localize type checks, we add a type annotation here.
blockht) (ann (cond
jump)] [(TestFalse? test)
[(TestOne? test) (format "if(~a===false){~a}"
(format "if(~a===1){~a}" (assemble-oparg (TestFalse-operand test)
(assemble-oparg (TestOne-operand test) blockht)
blockht) jump)]
jump)] [(TestTrue? test)
[(TestZero? test) (format "if(~a!==false){~a}"
(format "if(~a===0){~a}" (assemble-oparg (TestTrue-operand test)
(assemble-oparg (TestZero-operand test) blockht)
blockht) jump)]
jump)] [(TestOne? test)
[(TestClosureArityMismatch? test) (format "if(~a===1){~a}"
(format "if(!RT.isArityMatching((~a).racketArity,~a)){~a}" (assemble-oparg (TestOne-operand test)
(assemble-oparg (TestClosureArityMismatch-closure test) blockht)
blockht) jump)]
(assemble-oparg (TestClosureArityMismatch-n test) [(TestZero? test)
blockht) (format "if(~a===0){~a}"
jump)]) (assemble-oparg (TestZero-operand test)
String))] blockht)
jump)]
[(Goto? stmt) [(TestClosureArityMismatch? test)
(assemble-jump (Goto-target stmt) (format "if(!RT.isArityMatching((~a).racketArity,~a)){~a}"
blockht)] (assemble-oparg (TestClosureArityMismatch-closure test)
blockht)
[(PushControlFrame/Generic? stmt) (assemble-oparg (TestClosureArityMismatch-n test)
"M.c.push(new RT.Frame());"] blockht)
jump)])
[(PushControlFrame/Call? stmt) String))]
(format "M.c.push(new RT.CallFrame(~a,M.p));"
(let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Call-label stmt)]) [(Goto? stmt)
(cond (assemble-jump (Goto-target stmt)
[(symbol? label) blockht)]
(assemble-label (make-Label label)
blockht)] [(PushControlFrame/Generic? stmt)
[(LinkedLabel? label) "M.c.push(new RT.Frame());"]
(assemble-label (make-Label (LinkedLabel-label label))
blockht)])))] [(PushControlFrame/Call? stmt)
(format "M.c.push(new RT.CallFrame(~a,M.p));"
[(PushControlFrame/Prompt? stmt) (let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Call-label stmt)])
;; fixme: use a different frame structure (cond
(format "M.c.push(new RT.PromptFrame(~a,~a));" [(symbol? label)
(let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Prompt-label stmt)]) (assemble-label (make-Label label)
(cond blockht)]
[(symbol? label) [(LinkedLabel? label)
(assemble-label (make-Label label) (assemble-label (make-Label (LinkedLabel-label label))
blockht)] blockht)])))]
[(LinkedLabel? label)
(assemble-label (make-Label (LinkedLabel-label label)) [(PushControlFrame/Prompt? stmt)
blockht)])) ;; fixme: use a different frame structure
(format "M.c.push(new RT.PromptFrame(~a,~a));"
(let: ([tag : (U DefaultContinuationPromptTag OpArg) (let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Prompt-label stmt)])
(PushControlFrame/Prompt-tag stmt)]) (cond
(cond [(symbol? label)
[(DefaultContinuationPromptTag? tag) (assemble-label (make-Label label)
(assemble-default-continuation-prompt-tag)] blockht)]
[(OpArg? tag) [(LinkedLabel? label)
(assemble-oparg tag blockht)])))] (assemble-label (make-Label (LinkedLabel-label label))
blockht)]))
[(PopControlFrame? stmt)
"M.c.pop();"] (let: ([tag : (U DefaultContinuationPromptTag OpArg)
(PushControlFrame/Prompt-tag stmt)])
[(PushEnvironment? stmt) (cond
(cond [(= (PushEnvironment-n stmt) 0) [(DefaultContinuationPromptTag? tag)
""] (assemble-default-continuation-prompt-tag)]
[(PushEnvironment-unbox? stmt) [(OpArg? tag)
(format "M.e.push(~a);" (string-join (assemble-oparg tag blockht)])))]
(build-list (PushEnvironment-n stmt)
(lambda: ([i : Natural]) [(PopControlFrame? stmt)
"[void(0)]")) "M.c.pop();"]
","))]
[else [(PushEnvironment? stmt)
(format "M.e.push(~a);" (string-join (cond [(= (PushEnvironment-n stmt) 0)
(build-list (PushEnvironment-n stmt) ""]
(lambda: ([i : Natural]) [(PushEnvironment-unbox? stmt)
"void(0)")) (format "M.e.push(~a);" (string-join
",")) (build-list (PushEnvironment-n stmt)
;(format "M.e.length+=~a;" (PushEnvironment-n stmt)) (lambda: ([i : Natural])
])] "[void(0)]"))
[(PopEnvironment? stmt) ","))]
(let: ([skip : OpArg (PopEnvironment-skip stmt)]) [else
(cond (format "M.e.push(~a);" (string-join
[(and (Const? skip) (= (ensure-natural (Const-const skip)) 0)) (build-list (PushEnvironment-n stmt)
(cond [(equal? (PopEnvironment-n stmt) (lambda: ([i : Natural])
(make-Const 1)) "void(0)"))
"M.e.pop();"] ","))
[else ;(format "M.e.length+=~a;" (PushEnvironment-n stmt))
(format "M.e.length-=~a;" ])]
(assemble-oparg (PopEnvironment-n stmt) blockht))])] [(PopEnvironment? stmt)
[else (let: ([skip : OpArg (PopEnvironment-skip stmt)])
(define skip (PopEnvironment-skip stmt)) (cond
(define n (PopEnvironment-n stmt)) [(and (Const? skip) (= (ensure-natural (Const-const skip)) 0))
(cond (cond [(equal? (PopEnvironment-n stmt)
[(and (Const? skip) (Const? n)) (make-Const 1))
(format "M.e.splice(M.e.length-~a,~a);" "M.e.pop();"]
(+ (ensure-natural (Const-const skip)) [else
(ensure-natural (Const-const n))) (format "M.e.length-=~a;"
(Const-const n))] (assemble-oparg (PopEnvironment-n stmt) blockht))])]
[else [else
(format "M.e.splice(M.e.length-(~a+~a),~a);" (define skip (PopEnvironment-skip stmt))
(assemble-oparg skip blockht) (define n (PopEnvironment-n stmt))
(assemble-oparg n blockht) (cond
(assemble-oparg n blockht))])]))] [(and (Const? skip) (Const? n))
(format "M.e.splice(M.e.length-~a,~a);"
[(PushImmediateOntoEnvironment? stmt) (+ (ensure-natural (Const-const skip))
(format "M.e.push(~a);" (ensure-natural (Const-const n)))
(let: ([val-string : String (Const-const n))]
(cond [(PushImmediateOntoEnvironment-box? stmt) [else
(format "[~a]" (assemble-oparg (PushImmediateOntoEnvironment-value stmt) (format "M.e.splice(M.e.length-(~a+~a),~a);"
blockht))] (assemble-oparg skip blockht)
[else (assemble-oparg n blockht)
(assemble-oparg (PushImmediateOntoEnvironment-value stmt) (assemble-oparg n blockht))])]))]
blockht)])])
val-string))] [(PushImmediateOntoEnvironment? stmt)
[(Comment? stmt) (format "M.e.push(~a);"
;; TODO: maybe comments should be emitted as JavaScript comments. (let: ([val-string : String
""])) (cond [(PushImmediateOntoEnvironment-box? stmt)
(format "[~a]" (assemble-oparg (PushImmediateOntoEnvironment-value stmt)
blockht))]
[else
(assemble-oparg (PushImmediateOntoEnvironment-value stmt)
blockht)])])
val-string))]
[(Comment? stmt)
(format "//~s\n" (Comment-val stmt))]))
(cond (cond
#;[(current-emit-debug-trace?) [emit-debug-trace?
(string-append (string-append
(format "if(window.console!==void(0)&&typeof(window.console.log)==='function'){window.console.log(~s);\n}" (format "if(window.console!==void(0)&&typeof(window.console.log)==='function'){window.console.log(~s);\n}"
(format "~a" stmt)) (format "~a" stmt))
assembled)] assembled)]
[else [else
assembled])) assembled]))
(define-predicate natural? Natural) (define-predicate natural? Natural)
@ -660,25 +658,25 @@ EOF
(: get-function-entry-and-exit-names ((Listof Statement) -> (Listof Symbol))) (: get-function-entry-and-exit-names ((Listof Statement) -> (Listof Symbol)))
(define (get-function-entry-and-exit-names stmts) (define (get-function-entry-and-exit-names stmts)
(cond (cond
[(empty? stmts) [(empty? stmts)
'()] '()]
[else [else
(define first-stmt (first stmts)) (define first-stmt (first stmts))
(cond (cond
[(LinkedLabel? first-stmt) [(LinkedLabel? first-stmt)
(cons (LinkedLabel-label first-stmt) (cons (LinkedLabel-label first-stmt)
(cons (LinkedLabel-linked-to first-stmt) (cons (LinkedLabel-linked-to first-stmt)
(get-function-entry-and-exit-names (rest stmts))))] (get-function-entry-and-exit-names (rest stmts))))]
[(AssignPrimOp? first-stmt) [(AssignPrimOp? first-stmt)
(define op (AssignPrimOp-op first-stmt)) (define op (AssignPrimOp-op first-stmt))
(cond (cond
[(MakeCompiledProcedure? op) [(MakeCompiledProcedure? op)
(cons (MakeCompiledProcedure-label op) (cons (MakeCompiledProcedure-label op)
(get-function-entry-and-exit-names (rest stmts)))] (get-function-entry-and-exit-names (rest stmts)))]
[(MakeCompiledProcedureShell? first-stmt) [(MakeCompiledProcedureShell? first-stmt)
(cons (MakeCompiledProcedureShell-label op) (cons (MakeCompiledProcedureShell-label op)
(get-function-entry-and-exit-names (rest stmts)))] (get-function-entry-and-exit-names (rest stmts)))]
[else
(get-function-entry-and-exit-names (rest stmts))])]
[else [else
(get-function-entry-and-exit-names (rest stmts))])] (get-function-entry-and-exit-names (rest stmts))])]))
[else
(get-function-entry-and-exit-names (rest stmts))])]))

2
version.rkt
View File

@ -7,4 +7,4 @@
(provide version) (provide version)
(: version String) (: version String)
(define version "1.195") (define version "1.198")