fixing indentation, enabling comments in emitted source
This commit is contained in:
Danny Yoo
parent
fc521f6f7b
commit
e9d3c207f7
|
|
@ -440,7 +440,7 @@
|
|||
(append-instruction-sequences
|
||||
(make-AssignImmediate 'argcount (make-Const 1))
|
||||
(make-Perform (make-RaiseContextExpectedValuesError!
|
||||
context))))]))]))
|
||||
context))))]))]))
|
||||
|
||||
|
||||
|
||||
|
|
@ -453,7 +453,7 @@
|
|||
cenv
|
||||
(append-instruction-sequences
|
||||
(make-AssignImmediate target (make-Const
|
||||
(ensure-const-value (Constant-v exp))))
|
||||
(ensure-const-value (Constant-v exp))))
|
||||
singular-context-check))))
|
||||
|
||||
|
||||
|
|
@ -476,8 +476,8 @@
|
|||
cenv
|
||||
(append-instruction-sequences
|
||||
(make-AssignImmediate target
|
||||
(make-EnvLexicalReference (LocalRef-depth exp)
|
||||
(LocalRef-unbox? exp)))
|
||||
(make-EnvLexicalReference (LocalRef-depth exp)
|
||||
(LocalRef-unbox? exp)))
|
||||
singular-context-check))))
|
||||
|
||||
|
||||
|
|
@ -493,32 +493,32 @@
|
|||
|
||||
;; If it's a module variable, we need to look there.
|
||||
(cond
|
||||
[(ModuleVariable? prefix-element)
|
||||
(cond [(kernel-module-name? (ModuleVariable-module-name prefix-element))
|
||||
(make-AssignPrimOp target
|
||||
(make-PrimitivesReference
|
||||
(kernel-module-variable->primitive-name
|
||||
prefix-element)
|
||||
))]
|
||||
[else
|
||||
(make-AssignImmediate
|
||||
target
|
||||
(make-EnvPrefixReference (ToplevelRef-depth exp)
|
||||
(ToplevelRef-pos exp)
|
||||
#t))])]
|
||||
[else
|
||||
(append-instruction-sequences
|
||||
(if (ToplevelRef-check-defined? exp)
|
||||
(make-Perform (make-CheckToplevelBound!
|
||||
(ToplevelRef-depth exp)
|
||||
(ToplevelRef-pos exp)))
|
||||
empty-instruction-sequence)
|
||||
(make-AssignImmediate
|
||||
target
|
||||
(make-EnvPrefixReference (ToplevelRef-depth exp)
|
||||
(ToplevelRef-pos exp)
|
||||
#f)))])
|
||||
singular-context-check))))
|
||||
[(ModuleVariable? prefix-element)
|
||||
(cond [(kernel-module-name? (ModuleVariable-module-name prefix-element))
|
||||
(make-AssignPrimOp target
|
||||
(make-PrimitivesReference
|
||||
(kernel-module-variable->primitive-name
|
||||
prefix-element)
|
||||
))]
|
||||
[else
|
||||
(make-AssignImmediate
|
||||
target
|
||||
(make-EnvPrefixReference (ToplevelRef-depth exp)
|
||||
(ToplevelRef-pos exp)
|
||||
#t))])]
|
||||
[else
|
||||
(append-instruction-sequences
|
||||
(if (ToplevelRef-check-defined? exp)
|
||||
(make-Perform (make-CheckToplevelBound!
|
||||
(ToplevelRef-depth exp)
|
||||
(ToplevelRef-pos exp)))
|
||||
empty-instruction-sequence)
|
||||
(make-AssignImmediate
|
||||
target
|
||||
(make-EnvPrefixReference (ToplevelRef-depth exp)
|
||||
(ToplevelRef-pos exp)
|
||||
#f)))])
|
||||
singular-context-check))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -532,20 +532,20 @@
|
|||
(define prefix-element (list-ref (Prefix-names prefix) (ToplevelSet-pos exp)))
|
||||
(let ([get-value-code
|
||||
(cond
|
||||
[(ModuleVariable? prefix-element)
|
||||
(compile (ToplevelSet-value exp)
|
||||
cenv
|
||||
(make-EnvPrefixReference (ToplevelSet-depth exp)
|
||||
(ToplevelSet-pos exp)
|
||||
#t)
|
||||
next-linkage/expects-single)]
|
||||
[else
|
||||
(compile (ToplevelSet-value exp)
|
||||
cenv
|
||||
(make-EnvPrefixReference (ToplevelSet-depth exp)
|
||||
(ToplevelSet-pos exp)
|
||||
#f)
|
||||
next-linkage/expects-single)])]
|
||||
[(ModuleVariable? prefix-element)
|
||||
(compile (ToplevelSet-value exp)
|
||||
cenv
|
||||
(make-EnvPrefixReference (ToplevelSet-depth exp)
|
||||
(ToplevelSet-pos exp)
|
||||
#t)
|
||||
next-linkage/expects-single)]
|
||||
[else
|
||||
(compile (ToplevelSet-value exp)
|
||||
cenv
|
||||
(make-EnvPrefixReference (ToplevelSet-depth exp)
|
||||
(ToplevelSet-pos exp)
|
||||
#f)
|
||||
next-linkage/expects-single)])]
|
||||
[singular-context-check (emit-singular-context linkage)])
|
||||
(end-with-linkage
|
||||
linkage
|
||||
|
|
@ -576,7 +576,7 @@
|
|||
(append-instruction-sequences
|
||||
p-code
|
||||
(make-TestAndJump (make-TestFalse (make-Reg 'val))
|
||||
f-branch:)
|
||||
f-branch:)
|
||||
c-code
|
||||
f-branch: a-code
|
||||
(if (NextLinkage? linkage)
|
||||
|
|
@ -648,7 +648,6 @@
|
|||
(let ([evaluate-and-save-first-expression
|
||||
(let ([after-first-seq (make-label 'afterFirstSeqEvaluated)])
|
||||
(append-instruction-sequences
|
||||
(make-Comment "begin0")
|
||||
;; 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)
|
||||
|
||||
|
|
@ -659,10 +658,10 @@
|
|||
;; Next, we save those values temporarily in a throwaway control frame.
|
||||
(make-PushControlFrame/Generic)
|
||||
(make-AssignImmediate (make-ControlFrameTemporary 'pendingBegin0Count)
|
||||
(make-Reg 'argcount))
|
||||
(make-Reg 'argcount))
|
||||
(make-Perform (make-UnspliceRestFromStack! (make-Const 0) (make-Reg 'argcount)))
|
||||
(make-AssignImmediate (make-ControlFrameTemporary 'pendingBegin0Values)
|
||||
(make-EnvLexicalReference 0 #f))
|
||||
(make-EnvLexicalReference 0 #f))
|
||||
(make-PopEnvironment (make-Const 1) (make-Const 0))))]
|
||||
|
||||
[reinstate-values-on-stack
|
||||
|
|
@ -764,7 +763,6 @@
|
|||
(append-instruction-sequences
|
||||
;; Make some temporary space for the lambdas
|
||||
|
||||
(make-Comment "scratch space for case-lambda")
|
||||
(make-PushEnvironment n #f)
|
||||
|
||||
;; Compile each of the lambdas
|
||||
|
|
@ -870,36 +868,44 @@
|
|||
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))
|
||||
;; Compiles the body of the lambda in the appropriate environment.
|
||||
;; Closures will target their value to the 'val register, and use return linkage.
|
||||
(define (compile-lambda-body exp cenv)
|
||||
(let: ([maybe-unsplice-rest-argument : InstructionSequence
|
||||
(if (Lam-rest? exp)
|
||||
(make-Perform
|
||||
(make-UnspliceRestFromStack!
|
||||
(make-Const (Lam-num-parameters exp))
|
||||
(new-SubtractArg (make-Reg 'argcount)
|
||||
(make-Const (Lam-num-parameters exp)))))
|
||||
empty-instruction-sequence)]
|
||||
[maybe-install-closure-values : InstructionSequence
|
||||
(if (not (empty? (Lam-closure-map exp)))
|
||||
(append-instruction-sequences
|
||||
(make-Comment (format "installing closure for ~s" (Lam-name exp)))
|
||||
(make-Perform (make-InstallClosureValues!
|
||||
(length (Lam-closure-map exp)))))
|
||||
empty-instruction-sequence)]
|
||||
[lam-body-code : InstructionSequence
|
||||
(compile (Lam-body exp)
|
||||
(extract-lambda-cenv exp cenv)
|
||||
'val
|
||||
return-linkage)])
|
||||
(parameterize ([current-lambda-body-being-compiled exp])
|
||||
(let: ([maybe-unsplice-rest-argument : InstructionSequence
|
||||
(if (Lam-rest? exp)
|
||||
(make-Perform
|
||||
(make-UnspliceRestFromStack!
|
||||
(make-Const (Lam-num-parameters exp))
|
||||
(new-SubtractArg (make-Reg 'argcount)
|
||||
(make-Const (Lam-num-parameters exp)))))
|
||||
empty-instruction-sequence)]
|
||||
[maybe-install-closure-values : InstructionSequence
|
||||
(if (not (empty? (Lam-closure-map exp)))
|
||||
(append-instruction-sequences
|
||||
(make-Perform (make-InstallClosureValues!
|
||||
(length (Lam-closure-map exp)))))
|
||||
empty-instruction-sequence)]
|
||||
[lam-body-code : InstructionSequence
|
||||
(compile (Lam-body exp)
|
||||
(extract-lambda-cenv exp cenv)
|
||||
'val
|
||||
return-linkage)])
|
||||
|
||||
(append-instruction-sequences
|
||||
(Lam-entry-label exp)
|
||||
maybe-unsplice-rest-argument
|
||||
maybe-install-closure-values
|
||||
lam-body-code)))
|
||||
(append-instruction-sequences
|
||||
(Lam-entry-label exp)
|
||||
(Comment (format "lambda body for ~a" (Lam-name exp)))
|
||||
maybe-unsplice-rest-argument
|
||||
maybe-install-closure-values
|
||||
lam-body-code))))
|
||||
|
||||
|
||||
(: compile-case-lambda-body (CaseLam CompileTimeEnvironment -> InstructionSequence))
|
||||
|
|
@ -914,21 +920,21 @@
|
|||
(let ([not-match (make-label 'notMatch)])
|
||||
(append-instruction-sequences
|
||||
(make-TestAndJump (make-TestClosureArityMismatch
|
||||
(make-CompiledProcedureClosureReference
|
||||
(make-Reg 'proc)
|
||||
i)
|
||||
(make-Reg 'argcount))
|
||||
not-match)
|
||||
(make-CompiledProcedureClosureReference
|
||||
(make-Reg 'proc)
|
||||
i)
|
||||
(make-Reg 'argcount))
|
||||
not-match)
|
||||
;; Set the procedure register to the lam
|
||||
(make-AssignImmediate
|
||||
'proc
|
||||
(make-CompiledProcedureClosureReference (make-Reg 'proc) i))
|
||||
|
||||
(make-Goto (make-Label
|
||||
(cond [(Lam? lam)
|
||||
(Lam-entry-label lam)]
|
||||
[(EmptyClosureReference? lam)
|
||||
(EmptyClosureReference-entry-label lam)])))
|
||||
(cond [(Lam? lam)
|
||||
(Lam-entry-label lam)]
|
||||
[(EmptyClosureReference? lam)
|
||||
(EmptyClosureReference-entry-label lam)])))
|
||||
|
||||
not-match)))
|
||||
(CaseLam-clauses exp)
|
||||
|
|
@ -1058,12 +1064,11 @@
|
|||
'val))))])
|
||||
(append-instruction-sequences
|
||||
|
||||
(make-Comment "scratch space for general application")
|
||||
(make-PushEnvironment (length (App-operands exp)) #f)
|
||||
proc-code
|
||||
(juggle-operands operand-codes)
|
||||
(make-AssignImmediate 'argcount
|
||||
(make-Const (length (App-operands exp))))
|
||||
(make-Const (length (App-operands exp))))
|
||||
(compile-general-procedure-call cenv
|
||||
(make-Const (length (App-operands exp)))
|
||||
target
|
||||
|
|
@ -1143,11 +1148,11 @@
|
|||
(make-EnvLexicalReference i #f)))))
|
||||
(make-AssignImmediate 'proc (make-PrimitiveKernelValue kernel-op))
|
||||
(make-AssignImmediate 'argcount
|
||||
(make-Const (length (App-operands exp))))
|
||||
(make-Const (length (App-operands exp))))
|
||||
(make-Perform (make-RaiseArityMismatchError!
|
||||
(make-Reg 'proc)
|
||||
expected-arity
|
||||
(make-Const n))))))
|
||||
(make-Reg 'proc)
|
||||
expected-arity
|
||||
(make-Const n))))))
|
||||
|
||||
(cond
|
||||
[(IncorrectArity? expected-operand-types)
|
||||
|
|
@ -1190,11 +1195,11 @@
|
|||
linkage cenv
|
||||
(append-instruction-sequences
|
||||
(make-AssignPrimOp target
|
||||
(make-CallKernelPrimitiveProcedure
|
||||
kernel-op
|
||||
operand-poss
|
||||
expected-operand-types
|
||||
typechecks?))
|
||||
(make-CallKernelPrimitiveProcedure
|
||||
kernel-op
|
||||
operand-poss
|
||||
expected-operand-types
|
||||
typechecks?))
|
||||
singular-context-check)))]
|
||||
|
||||
[else
|
||||
|
|
@ -1224,7 +1229,7 @@
|
|||
rest-operands))]
|
||||
[(constant-operand-knowledge)
|
||||
(map (lambda: ([arg : Expression])
|
||||
(extract-static-knowledge arg extended-cenv))
|
||||
(extract-static-knowledge arg extended-cenv))
|
||||
constant-operands)]
|
||||
|
||||
[(operand-knowledge)
|
||||
|
|
@ -1304,11 +1309,11 @@
|
|||
(LocalRef-unbox? e))]
|
||||
[(ToplevelRef? e)
|
||||
(cond
|
||||
[(ModuleVariable? k)
|
||||
(make-EnvPrefixReference (ToplevelRef-depth e) (ToplevelRef-pos e) #t)]
|
||||
[(ModuleVariable? k)
|
||||
(make-EnvPrefixReference (ToplevelRef-depth e) (ToplevelRef-pos e) #t)]
|
||||
|
||||
[else
|
||||
(make-EnvPrefixReference (ToplevelRef-depth e) (ToplevelRef-pos e) #f)])]
|
||||
[else
|
||||
(make-EnvPrefixReference (ToplevelRef-depth e) (ToplevelRef-pos e) #f)])]
|
||||
[else
|
||||
(error 'all-operands-are-constant "Impossible")]))
|
||||
rands
|
||||
|
|
@ -1428,7 +1433,6 @@
|
|||
'proc
|
||||
next-linkage/expects-single)])
|
||||
(append-instruction-sequences
|
||||
(make-Comment "scratch space for statically known lambda application")
|
||||
(make-PushEnvironment (length (App-operands exp)) #f)
|
||||
(apply append-instruction-sequences operand-codes)
|
||||
proc-code
|
||||
|
|
@ -1458,9 +1462,9 @@
|
|||
(append-instruction-sequences
|
||||
(car ops)
|
||||
(make-AssignImmediate 'proc
|
||||
(make-EnvLexicalReference n #f))
|
||||
(make-EnvLexicalReference n #f))
|
||||
(make-AssignImmediate (make-EnvLexicalReference n #f)
|
||||
(make-Reg 'val))))]
|
||||
(make-Reg 'val))))]
|
||||
[else
|
||||
;; Otherwise, add instructions to juggle the operator and operands in the stack.
|
||||
(append-instruction-sequences (car ops)
|
||||
|
|
@ -1544,7 +1548,7 @@
|
|||
(linkage-context linkage)))])
|
||||
(append-instruction-sequences
|
||||
(make-AssignImmediate 'argcount
|
||||
(make-Const n))
|
||||
(make-Const n))
|
||||
(compile-compiled-procedure-application cenv
|
||||
(make-Const n)
|
||||
(make-Label
|
||||
|
|
@ -1685,8 +1689,8 @@
|
|||
on-return/multiple
|
||||
;; if the wrong number of arguments come in, die
|
||||
(make-TestAndJump (make-TestZero (new-SubtractArg (make-Reg 'argcount)
|
||||
(make-Const context)))
|
||||
after-value-check)
|
||||
(make-Const context)))
|
||||
after-value-check)
|
||||
on-return
|
||||
(make-Perform
|
||||
(make-RaiseContextExpectedValuesError! context))
|
||||
|
|
@ -1784,7 +1788,6 @@
|
|||
linkage
|
||||
extended-cenv
|
||||
(append-instruction-sequences
|
||||
(make-Comment "scratch space for let1")
|
||||
(make-PushEnvironment 1 #f)
|
||||
rhs-code
|
||||
body-code
|
||||
|
|
@ -1859,7 +1862,6 @@
|
|||
linkage
|
||||
extended-cenv
|
||||
(append-instruction-sequences
|
||||
(make-Comment "scratch space for let-void")
|
||||
(make-PushEnvironment n (LetVoid-boxes? exp))
|
||||
body-code
|
||||
after-body-code
|
||||
|
|
@ -1952,9 +1954,8 @@
|
|||
(map (lambda: ([lam : Lam]
|
||||
[i : Natural])
|
||||
(append-instruction-sequences
|
||||
(make-Comment (format "Installing shell for ~s\n" (Lam-name lam)))
|
||||
(make-Perform (make-FixClosureShellMap! i
|
||||
(Lam-closure-map lam)))))
|
||||
(Lam-closure-map lam)))))
|
||||
(LetRec-procs exp)
|
||||
(build-list n (lambda: ([i : Natural]) i))))
|
||||
|
||||
|
|
@ -1968,7 +1969,6 @@
|
|||
(: compile-install-value (InstallValue CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-install-value exp cenv target linkage)
|
||||
(append-instruction-sequences
|
||||
(make-Comment "install-value")
|
||||
(let ([count (InstallValue-count exp)])
|
||||
(cond [(= count 0)
|
||||
(end-with-linkage
|
||||
|
|
@ -1980,8 +1980,6 @@
|
|||
(make-NextLinkage 0)))]
|
||||
[(= count 1)
|
||||
(append-instruction-sequences
|
||||
(make-Comment (format "installing single value into ~s"
|
||||
(InstallValue-depth exp)))
|
||||
(end-with-linkage
|
||||
linkage
|
||||
cenv
|
||||
|
|
@ -1994,7 +1992,6 @@
|
|||
linkage
|
||||
cenv
|
||||
(append-instruction-sequences
|
||||
(make-Comment "install-value: evaluating values")
|
||||
(compile (InstallValue-body exp)
|
||||
cenv
|
||||
'val
|
||||
|
|
@ -2003,7 +2000,6 @@
|
|||
(map (lambda: ([to : EnvLexicalReference]
|
||||
[from : OpArg])
|
||||
(append-instruction-sequences
|
||||
(make-Comment "install-value: installing value")
|
||||
(make-AssignImmediate to from)))
|
||||
(build-list count (lambda: ([i : Natural])
|
||||
(make-EnvLexicalReference (+ i
|
||||
|
|
@ -2021,7 +2017,7 @@
|
|||
(define (compile-box-environment-value exp cenv target linkage)
|
||||
(append-instruction-sequences
|
||||
(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)))
|
||||
|
||||
|
||||
|
|
@ -2051,15 +2047,15 @@
|
|||
context on-return/multiple: on-return:)]
|
||||
[maybe-migrate-val-to-target
|
||||
(cond
|
||||
[(eq? target 'val)
|
||||
empty-instruction-sequence]
|
||||
[else
|
||||
(make-AssignImmediate target (make-Reg 'val))])])
|
||||
[(eq? target 'val)
|
||||
empty-instruction-sequence]
|
||||
[else
|
||||
(make-AssignImmediate target (make-Reg 'val))])])
|
||||
(append-instruction-sequences
|
||||
(make-PushControlFrame/Call on-return:)
|
||||
(compile (WithContMark-key exp) cenv 'val next-linkage/expects-single)
|
||||
(make-AssignImmediate (make-ControlFrameTemporary 'pendingContinuationMarkKey)
|
||||
(make-Reg 'val))
|
||||
(make-Reg 'val))
|
||||
(compile (WithContMark-value exp) cenv 'val next-linkage/expects-single)
|
||||
(make-Perform (make-InstallContinuationMarkEntry!))
|
||||
(compile (WithContMark-body exp) cenv 'val return-linkage/nontail)
|
||||
|
|
|
|||
|
|
@ -193,8 +193,8 @@
|
|||
]
|
||||
|
||||
[(Comment? a-stmt)
|
||||
(loop (rest stmts))
|
||||
;(cons a-stmt (loop (rest stmts)))
|
||||
;(loop (rest stmts))
|
||||
(cons a-stmt (loop (rest stmts)))
|
||||
]
|
||||
|
||||
[(AssignImmediate? a-stmt)
|
||||
|
|
@ -386,7 +386,7 @@
|
|||
[(PopControlFrame? stmt)
|
||||
#f]
|
||||
[(Comment? stmt)
|
||||
#t]))
|
||||
#f]))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -13,8 +13,7 @@
|
|||
"../sets.rkt"
|
||||
"../helpers.rkt"
|
||||
racket/string
|
||||
racket/list
|
||||
racket/match)
|
||||
racket/list)
|
||||
(require/typed "../logger.rkt"
|
||||
[log-debug (String -> Void)])
|
||||
|
||||
|
|
@ -26,7 +25,7 @@
|
|||
|
||||
|
||||
;; Parameter that controls the generation of a trace.
|
||||
(define current-emit-debug-trace? (make-parameter #f))
|
||||
(define emit-debug-trace? #f)
|
||||
|
||||
|
||||
|
||||
|
|
@ -69,7 +68,7 @@ for (param in params) {
|
|||
}
|
||||
}
|
||||
EOF
|
||||
op)
|
||||
op)
|
||||
(fprintf op "M.trampoline(~a, true); })"
|
||||
(assemble-label (make-Label (BasicBlock-name (first basic-blocks)))
|
||||
blockht)))
|
||||
|
|
@ -111,8 +110,8 @@ EOF
|
|||
(cond
|
||||
[(set-contains? visited next-to-visit)
|
||||
#;(unless (set-contains? entry-points next-to-visit)
|
||||
(log-debug (format "Promoting ~a to an entry point" next-to-visit))
|
||||
(set-insert! entry-points next-to-visit))
|
||||
(log-debug (format "Promoting ~a to an entry point" next-to-visit))
|
||||
(set-insert! entry-points next-to-visit))
|
||||
(loop (rest queue))]
|
||||
[else
|
||||
(set-insert! visited next-to-visit)
|
||||
|
|
@ -146,19 +145,19 @@ EOF
|
|||
;; that if .mvr is missing, that the block only expects one.
|
||||
(define linked-to-block (hash-ref blockht (LinkedLabel-linked-to stmt)))
|
||||
(cond
|
||||
[(block-looks-like-context-expected-values? linked-to-block)
|
||||
=> (lambda (expected)
|
||||
(cond
|
||||
[(= expected 1)
|
||||
(void)]
|
||||
[else
|
||||
(fprintf op "~a.mvr=RT.si_context_expected(~a);\n"
|
||||
(munge-label-name (make-Label (LinkedLabel-label stmt)))
|
||||
expected)]))]
|
||||
[else
|
||||
(fprintf op "~a.mvr=~a;\n"
|
||||
(munge-label-name (make-Label (LinkedLabel-label stmt)))
|
||||
(assemble-label (make-Label (LinkedLabel-linked-to stmt)) blockht))])
|
||||
[(block-looks-like-context-expected-values? linked-to-block)
|
||||
=> (lambda (expected)
|
||||
(cond
|
||||
[(= expected 1)
|
||||
(void)]
|
||||
[else
|
||||
(fprintf op "~a.mvr=RT.si_context_expected(~a);\n"
|
||||
(munge-label-name (make-Label (LinkedLabel-label stmt)))
|
||||
expected)]))]
|
||||
[else
|
||||
(fprintf op "~a.mvr=~a;\n"
|
||||
(munge-label-name (make-Label (LinkedLabel-label stmt)))
|
||||
(assemble-label (make-Label (LinkedLabel-linked-to stmt)) blockht))])
|
||||
(next)]
|
||||
[(DebugPrint? stmt)
|
||||
(next)]
|
||||
|
|
@ -197,26 +196,26 @@ EOF
|
|||
(: 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)
|
||||
(cond
|
||||
[(block-looks-like-context-expected-values? a-basic-block)
|
||||
=>
|
||||
(lambda (expected)
|
||||
(cond
|
||||
[(= expected 1)
|
||||
'ok]
|
||||
[else
|
||||
(fprintf op "~a=RT.si_context_expected(~a);\n"
|
||||
(munge-label-name (make-Label (BasicBlock-name a-basic-block)))
|
||||
expected)
|
||||
'ok]))]
|
||||
[(block-looks-like-context-expected-values? a-basic-block)
|
||||
=>
|
||||
(lambda (expected)
|
||||
(cond
|
||||
[(= expected 1)
|
||||
'ok]
|
||||
[else
|
||||
(fprintf op "~a=RT.si_context_expected(~a);\n"
|
||||
(munge-label-name (make-Label (BasicBlock-name a-basic-block)))
|
||||
expected)
|
||||
'ok]))]
|
||||
|
||||
[(block-looks-like-pop-multiple-values-and-continue? a-basic-block)
|
||||
=>
|
||||
(lambda (target)
|
||||
(fprintf op "~a=RT.si_pop_multiple-values-and-continue(~a);"
|
||||
(munge-label-name (make-Label (BasicBlock-name a-basic-block)))
|
||||
target))]
|
||||
[else
|
||||
(default-assemble-basic-block a-basic-block blockht entry-points function-entry-and-exit-names op)]))
|
||||
[(block-looks-like-pop-multiple-values-and-continue? a-basic-block)
|
||||
=>
|
||||
(lambda (target)
|
||||
(fprintf op "~a=RT.si_pop_multiple-values-and-continue(~a);"
|
||||
(munge-label-name (make-Label (BasicBlock-name a-basic-block)))
|
||||
target))]
|
||||
[else
|
||||
(default-assemble-basic-block a-basic-block blockht entry-points function-entry-and-exit-names op)]))
|
||||
|
||||
|
||||
|
||||
|
|
@ -230,33 +229,33 @@ EOF
|
|||
(define last-stmt
|
||||
(last (BasicBlock-stmts a-basic-block)))
|
||||
(cond
|
||||
[(Goto? last-stmt)
|
||||
(define target (Goto-target last-stmt))
|
||||
(equal? target (make-Label (BasicBlock-name a-basic-block)))]
|
||||
[else #f])]
|
||||
[(Goto? last-stmt)
|
||||
(define target (Goto-target last-stmt))
|
||||
(equal? target (make-Label (BasicBlock-name a-basic-block)))]
|
||||
[else #f])]
|
||||
[else #f])))
|
||||
(cond
|
||||
[is-self-looping?
|
||||
(fprintf op "while(true){")
|
||||
(when (set-contains? function-entry-and-exit-names (BasicBlock-name a-basic-block))
|
||||
(fprintf op "if(--M.cbt<0){throw ~a;}\n"
|
||||
(assemble-label (make-Label (BasicBlock-name a-basic-block)) blockht)))
|
||||
[is-self-looping?
|
||||
(fprintf op "while(true){")
|
||||
(when (set-contains? function-entry-and-exit-names (BasicBlock-name a-basic-block))
|
||||
(fprintf op "if(--M.cbt<0){throw ~a;}\n"
|
||||
(assemble-label (make-Label (BasicBlock-name a-basic-block)) blockht)))
|
||||
|
||||
(assemble-block-statements (BasicBlock-name a-basic-block)
|
||||
(drop-right (BasicBlock-stmts a-basic-block) 1)
|
||||
blockht
|
||||
entry-points
|
||||
op)
|
||||
(fprintf op "}")]
|
||||
[else
|
||||
(when (set-contains? function-entry-and-exit-names (BasicBlock-name a-basic-block))
|
||||
(fprintf op "if(--M.cbt<0){throw ~a;}\n"
|
||||
(assemble-label (make-Label (BasicBlock-name a-basic-block)) blockht)))
|
||||
(assemble-block-statements (BasicBlock-name a-basic-block)
|
||||
(BasicBlock-stmts a-basic-block)
|
||||
blockht
|
||||
entry-points
|
||||
op)])
|
||||
(assemble-block-statements (BasicBlock-name a-basic-block)
|
||||
(drop-right (BasicBlock-stmts a-basic-block) 1)
|
||||
blockht
|
||||
entry-points
|
||||
op)
|
||||
(fprintf op "}")]
|
||||
[else
|
||||
(when (set-contains? function-entry-and-exit-names (BasicBlock-name a-basic-block))
|
||||
(fprintf op "if(--M.cbt<0){throw ~a;}\n"
|
||||
(assemble-label (make-Label (BasicBlock-name a-basic-block)) blockht)))
|
||||
(assemble-block-statements (BasicBlock-name a-basic-block)
|
||||
(BasicBlock-stmts a-basic-block)
|
||||
blockht
|
||||
entry-points
|
||||
op)])
|
||||
(display "};\n" op)
|
||||
'ok)
|
||||
|
||||
|
|
@ -325,59 +324,59 @@ EOF
|
|||
blockht)
|
||||
(assemble-oparg (TestClosureArityMismatch-n test)
|
||||
blockht))]))
|
||||
(display test-code op)
|
||||
(display "{" op)
|
||||
(cond
|
||||
[(set-contains? entry-points (TestAndJump-label stmt))
|
||||
(display (assemble-jump (make-Label (TestAndJump-label stmt))
|
||||
blockht) op)]
|
||||
[else
|
||||
(assemble-block-statements (BasicBlock-name
|
||||
(hash-ref blockht (TestAndJump-label stmt)))
|
||||
(BasicBlock-stmts
|
||||
(hash-ref blockht (TestAndJump-label stmt)))
|
||||
blockht
|
||||
entry-points
|
||||
op)])
|
||||
(display "}else{" op)
|
||||
(assemble-block-statements name (rest stmts) blockht entry-points op)
|
||||
(display "}" op)
|
||||
'ok]
|
||||
(display test-code op)
|
||||
(display "{" op)
|
||||
(cond
|
||||
[(set-contains? entry-points (TestAndJump-label stmt))
|
||||
(display (assemble-jump (make-Label (TestAndJump-label stmt))
|
||||
blockht) op)]
|
||||
[else
|
||||
(assemble-block-statements (BasicBlock-name
|
||||
(hash-ref blockht (TestAndJump-label stmt)))
|
||||
(BasicBlock-stmts
|
||||
(hash-ref blockht (TestAndJump-label stmt)))
|
||||
blockht
|
||||
entry-points
|
||||
op)])
|
||||
(display "}else{" op)
|
||||
(assemble-block-statements name (rest stmts) blockht entry-points op)
|
||||
(display "}" op)
|
||||
'ok]
|
||||
|
||||
[(Goto? stmt)
|
||||
(let loop ([stmt stmt])
|
||||
(define target (Goto-target stmt))
|
||||
(cond
|
||||
[(Label? target)
|
||||
(define target-block (hash-ref blockht (Label-name target)))
|
||||
(define target-name (BasicBlock-name target-block))
|
||||
(define target-statements (BasicBlock-stmts target-block))
|
||||
(cond
|
||||
;; Optimization: if the target block consists of a single goto,
|
||||
;; inline and follow the goto.
|
||||
[(and (not (empty? target-statements))
|
||||
(= 1 (length target-statements))
|
||||
(Goto? (first target-statements)))
|
||||
(loop (first target-statements))]
|
||||
[(set-contains? entry-points (Label-name target))
|
||||
(display (assemble-statement stmt blockht) op)
|
||||
'ok]
|
||||
[else
|
||||
(log-debug (format "Assembling inlined jump into ~a" (Label-name target)) )
|
||||
(assemble-block-statements target-name
|
||||
target-statements
|
||||
blockht
|
||||
entry-points
|
||||
op)])]
|
||||
[(Reg? target)
|
||||
(display (assemble-statement stmt blockht) op)
|
||||
'ok]
|
||||
[(ModuleEntry? target)
|
||||
(display (assemble-statement stmt blockht) op)
|
||||
'ok]
|
||||
[(CompiledProcedureEntry? target)
|
||||
(display (assemble-statement stmt blockht) op)
|
||||
'ok]))]
|
||||
[(Label? target)
|
||||
(define target-block (hash-ref blockht (Label-name target)))
|
||||
(define target-name (BasicBlock-name target-block))
|
||||
(define target-statements (BasicBlock-stmts target-block))
|
||||
(cond
|
||||
;; Optimization: if the target block consists of a single goto,
|
||||
;; inline and follow the goto.
|
||||
[(and (not (empty? target-statements))
|
||||
(= 1 (length target-statements))
|
||||
(Goto? (first target-statements)))
|
||||
(loop (first target-statements))]
|
||||
[(set-contains? entry-points (Label-name target))
|
||||
(display (assemble-statement stmt blockht) op)
|
||||
'ok]
|
||||
[else
|
||||
(log-debug (format "Assembling inlined jump into ~a" (Label-name target)) )
|
||||
(assemble-block-statements target-name
|
||||
target-statements
|
||||
blockht
|
||||
entry-points
|
||||
op)])]
|
||||
[(Reg? target)
|
||||
(display (assemble-statement stmt blockht) op)
|
||||
'ok]
|
||||
[(ModuleEntry? target)
|
||||
(display (assemble-statement stmt blockht) op)
|
||||
'ok]
|
||||
[(CompiledProcedureEntry? target)
|
||||
(display (assemble-statement stmt blockht) op)
|
||||
'ok]))]
|
||||
|
||||
|
||||
[(PushControlFrame/Generic? stmt)
|
||||
|
|
@ -488,163 +487,162 @@ EOF
|
|||
(define (assemble-statement stmt blockht)
|
||||
(define assembled
|
||||
(cond
|
||||
[(DebugPrint? stmt)
|
||||
(format "M.params.currentOutputPort.writeDomNode(M, $('<span/>').text(~a));"
|
||||
(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)
|
||||
[(DebugPrint? stmt)
|
||||
(format "M.params.currentOutputPort.writeDomNode(M, $('<span/>').text(~a));"
|
||||
(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)))]
|
||||
|
||||
[(Perform? stmt)
|
||||
(assemble-op-statement (Perform-op stmt) blockht)]
|
||||
[(AssignPrimOp? stmt)
|
||||
((assemble-target (AssignPrimOp-target stmt))
|
||||
(assemble-op-expression (AssignPrimOp-op stmt)
|
||||
blockht))]
|
||||
|
||||
[(TestAndJump? stmt)
|
||||
(let*: ([test : PrimitiveTest (TestAndJump-op stmt)]
|
||||
[jump : String (assemble-jump
|
||||
(make-Label (TestAndJump-label stmt))
|
||||
blockht)])
|
||||
;; to help localize type checks, we add a type annotation here.
|
||||
(ann (cond
|
||||
[(TestFalse? test)
|
||||
(format "if(~a===false){~a}"
|
||||
(assemble-oparg (TestFalse-operand test)
|
||||
blockht)
|
||||
jump)]
|
||||
[(TestTrue? test)
|
||||
(format "if(~a!==false){~a}"
|
||||
(assemble-oparg (TestTrue-operand test)
|
||||
blockht)
|
||||
jump)]
|
||||
[(TestOne? test)
|
||||
(format "if(~a===1){~a}"
|
||||
(assemble-oparg (TestOne-operand test)
|
||||
blockht)
|
||||
jump)]
|
||||
[(TestZero? test)
|
||||
(format "if(~a===0){~a}"
|
||||
(assemble-oparg (TestZero-operand test)
|
||||
blockht)
|
||||
jump)]
|
||||
[(TestClosureArityMismatch? test)
|
||||
(format "if(!RT.isArityMatching((~a).racketArity,~a)){~a}"
|
||||
(assemble-oparg (TestClosureArityMismatch-closure test)
|
||||
blockht)
|
||||
(assemble-oparg (TestClosureArityMismatch-n test)
|
||||
blockht)
|
||||
jump)])
|
||||
String))]
|
||||
[(Perform? stmt)
|
||||
(assemble-op-statement (Perform-op stmt) blockht)]
|
||||
|
||||
[(Goto? stmt)
|
||||
(assemble-jump (Goto-target stmt)
|
||||
blockht)]
|
||||
[(TestAndJump? stmt)
|
||||
(let*: ([test : PrimitiveTest (TestAndJump-op stmt)]
|
||||
[jump : String (assemble-jump
|
||||
(make-Label (TestAndJump-label stmt))
|
||||
blockht)])
|
||||
;; to help localize type checks, we add a type annotation here.
|
||||
(ann (cond
|
||||
[(TestFalse? test)
|
||||
(format "if(~a===false){~a}"
|
||||
(assemble-oparg (TestFalse-operand test)
|
||||
blockht)
|
||||
jump)]
|
||||
[(TestTrue? test)
|
||||
(format "if(~a!==false){~a}"
|
||||
(assemble-oparg (TestTrue-operand test)
|
||||
blockht)
|
||||
jump)]
|
||||
[(TestOne? test)
|
||||
(format "if(~a===1){~a}"
|
||||
(assemble-oparg (TestOne-operand test)
|
||||
blockht)
|
||||
jump)]
|
||||
[(TestZero? test)
|
||||
(format "if(~a===0){~a}"
|
||||
(assemble-oparg (TestZero-operand test)
|
||||
blockht)
|
||||
jump)]
|
||||
[(TestClosureArityMismatch? test)
|
||||
(format "if(!RT.isArityMatching((~a).racketArity,~a)){~a}"
|
||||
(assemble-oparg (TestClosureArityMismatch-closure test)
|
||||
blockht)
|
||||
(assemble-oparg (TestClosureArityMismatch-n test)
|
||||
blockht)
|
||||
jump)])
|
||||
String))]
|
||||
|
||||
[(PushControlFrame/Generic? stmt)
|
||||
"M.c.push(new RT.Frame());"]
|
||||
[(Goto? stmt)
|
||||
(assemble-jump (Goto-target stmt)
|
||||
blockht)]
|
||||
|
||||
[(PushControlFrame/Call? stmt)
|
||||
(format "M.c.push(new RT.CallFrame(~a,M.p));"
|
||||
(let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Call-label stmt)])
|
||||
(cond
|
||||
[(symbol? label)
|
||||
(assemble-label (make-Label label)
|
||||
blockht)]
|
||||
[(LinkedLabel? label)
|
||||
(assemble-label (make-Label (LinkedLabel-label label))
|
||||
blockht)])))]
|
||||
[(PushControlFrame/Generic? stmt)
|
||||
"M.c.push(new RT.Frame());"]
|
||||
|
||||
[(PushControlFrame/Prompt? stmt)
|
||||
;; fixme: use a different frame structure
|
||||
(format "M.c.push(new RT.PromptFrame(~a,~a));"
|
||||
(let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Prompt-label stmt)])
|
||||
(cond
|
||||
[(symbol? label)
|
||||
(assemble-label (make-Label label)
|
||||
blockht)]
|
||||
[(LinkedLabel? label)
|
||||
(assemble-label (make-Label (LinkedLabel-label label))
|
||||
blockht)]))
|
||||
[(PushControlFrame/Call? stmt)
|
||||
(format "M.c.push(new RT.CallFrame(~a,M.p));"
|
||||
(let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Call-label stmt)])
|
||||
(cond
|
||||
[(symbol? label)
|
||||
(assemble-label (make-Label label)
|
||||
blockht)]
|
||||
[(LinkedLabel? label)
|
||||
(assemble-label (make-Label (LinkedLabel-label label))
|
||||
blockht)])))]
|
||||
|
||||
(let: ([tag : (U DefaultContinuationPromptTag OpArg)
|
||||
(PushControlFrame/Prompt-tag stmt)])
|
||||
(cond
|
||||
[(DefaultContinuationPromptTag? tag)
|
||||
(assemble-default-continuation-prompt-tag)]
|
||||
[(OpArg? tag)
|
||||
(assemble-oparg tag blockht)])))]
|
||||
[(PushControlFrame/Prompt? stmt)
|
||||
;; fixme: use a different frame structure
|
||||
(format "M.c.push(new RT.PromptFrame(~a,~a));"
|
||||
(let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Prompt-label stmt)])
|
||||
(cond
|
||||
[(symbol? label)
|
||||
(assemble-label (make-Label label)
|
||||
blockht)]
|
||||
[(LinkedLabel? label)
|
||||
(assemble-label (make-Label (LinkedLabel-label label))
|
||||
blockht)]))
|
||||
|
||||
[(PopControlFrame? stmt)
|
||||
"M.c.pop();"]
|
||||
(let: ([tag : (U DefaultContinuationPromptTag OpArg)
|
||||
(PushControlFrame/Prompt-tag stmt)])
|
||||
(cond
|
||||
[(DefaultContinuationPromptTag? tag)
|
||||
(assemble-default-continuation-prompt-tag)]
|
||||
[(OpArg? tag)
|
||||
(assemble-oparg tag blockht)])))]
|
||||
|
||||
[(PushEnvironment? stmt)
|
||||
(cond [(= (PushEnvironment-n stmt) 0)
|
||||
""]
|
||||
[(PushEnvironment-unbox? stmt)
|
||||
(format "M.e.push(~a);" (string-join
|
||||
(build-list (PushEnvironment-n stmt)
|
||||
(lambda: ([i : Natural])
|
||||
"[void(0)]"))
|
||||
","))]
|
||||
[else
|
||||
(format "M.e.push(~a);" (string-join
|
||||
(build-list (PushEnvironment-n stmt)
|
||||
(lambda: ([i : Natural])
|
||||
"void(0)"))
|
||||
","))
|
||||
;(format "M.e.length+=~a;" (PushEnvironment-n stmt))
|
||||
])]
|
||||
[(PopEnvironment? stmt)
|
||||
(let: ([skip : OpArg (PopEnvironment-skip stmt)])
|
||||
(cond
|
||||
[(and (Const? skip) (= (ensure-natural (Const-const skip)) 0))
|
||||
(cond [(equal? (PopEnvironment-n stmt)
|
||||
(make-Const 1))
|
||||
"M.e.pop();"]
|
||||
[else
|
||||
(format "M.e.length-=~a;"
|
||||
(assemble-oparg (PopEnvironment-n stmt) blockht))])]
|
||||
[else
|
||||
(define skip (PopEnvironment-skip stmt))
|
||||
(define n (PopEnvironment-n stmt))
|
||||
(cond
|
||||
[(and (Const? skip) (Const? n))
|
||||
(format "M.e.splice(M.e.length-~a,~a);"
|
||||
(+ (ensure-natural (Const-const skip))
|
||||
(ensure-natural (Const-const n)))
|
||||
(Const-const n))]
|
||||
[else
|
||||
(format "M.e.splice(M.e.length-(~a+~a),~a);"
|
||||
(assemble-oparg skip blockht)
|
||||
(assemble-oparg n blockht)
|
||||
(assemble-oparg n blockht))])]))]
|
||||
[(PopControlFrame? stmt)
|
||||
"M.c.pop();"]
|
||||
|
||||
[(PushImmediateOntoEnvironment? stmt)
|
||||
(format "M.e.push(~a);"
|
||||
(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)
|
||||
;; TODO: maybe comments should be emitted as JavaScript comments.
|
||||
""]))
|
||||
[(PushEnvironment? stmt)
|
||||
(cond [(= (PushEnvironment-n stmt) 0)
|
||||
""]
|
||||
[(PushEnvironment-unbox? stmt)
|
||||
(format "M.e.push(~a);" (string-join
|
||||
(build-list (PushEnvironment-n stmt)
|
||||
(lambda: ([i : Natural])
|
||||
"[void(0)]"))
|
||||
","))]
|
||||
[else
|
||||
(format "M.e.push(~a);" (string-join
|
||||
(build-list (PushEnvironment-n stmt)
|
||||
(lambda: ([i : Natural])
|
||||
"void(0)"))
|
||||
","))
|
||||
;(format "M.e.length+=~a;" (PushEnvironment-n stmt))
|
||||
])]
|
||||
[(PopEnvironment? stmt)
|
||||
(let: ([skip : OpArg (PopEnvironment-skip stmt)])
|
||||
(cond
|
||||
[(and (Const? skip) (= (ensure-natural (Const-const skip)) 0))
|
||||
(cond [(equal? (PopEnvironment-n stmt)
|
||||
(make-Const 1))
|
||||
"M.e.pop();"]
|
||||
[else
|
||||
(format "M.e.length-=~a;"
|
||||
(assemble-oparg (PopEnvironment-n stmt) blockht))])]
|
||||
[else
|
||||
(define skip (PopEnvironment-skip stmt))
|
||||
(define n (PopEnvironment-n stmt))
|
||||
(cond
|
||||
[(and (Const? skip) (Const? n))
|
||||
(format "M.e.splice(M.e.length-~a,~a);"
|
||||
(+ (ensure-natural (Const-const skip))
|
||||
(ensure-natural (Const-const n)))
|
||||
(Const-const n))]
|
||||
[else
|
||||
(format "M.e.splice(M.e.length-(~a+~a),~a);"
|
||||
(assemble-oparg skip blockht)
|
||||
(assemble-oparg n blockht)
|
||||
(assemble-oparg n blockht))])]))]
|
||||
|
||||
[(PushImmediateOntoEnvironment? stmt)
|
||||
(format "M.e.push(~a);"
|
||||
(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
|
||||
#;[(current-emit-debug-trace?)
|
||||
(string-append
|
||||
(format "if(window.console!==void(0)&&typeof(window.console.log)==='function'){window.console.log(~s);\n}"
|
||||
(format "~a" stmt))
|
||||
assembled)]
|
||||
[else
|
||||
assembled]))
|
||||
[emit-debug-trace?
|
||||
(string-append
|
||||
(format "if(window.console!==void(0)&&typeof(window.console.log)==='function'){window.console.log(~s);\n}"
|
||||
(format "~a" stmt))
|
||||
assembled)]
|
||||
[else
|
||||
assembled]))
|
||||
|
||||
|
||||
(define-predicate natural? Natural)
|
||||
|
|
@ -660,25 +658,25 @@ EOF
|
|||
(: get-function-entry-and-exit-names ((Listof Statement) -> (Listof Symbol)))
|
||||
(define (get-function-entry-and-exit-names stmts)
|
||||
(cond
|
||||
[(empty? stmts)
|
||||
'()]
|
||||
[else
|
||||
(define first-stmt (first stmts))
|
||||
(cond
|
||||
[(LinkedLabel? first-stmt)
|
||||
(cons (LinkedLabel-label first-stmt)
|
||||
(cons (LinkedLabel-linked-to first-stmt)
|
||||
(get-function-entry-and-exit-names (rest stmts))))]
|
||||
[(AssignPrimOp? first-stmt)
|
||||
(define op (AssignPrimOp-op first-stmt))
|
||||
(cond
|
||||
[(MakeCompiledProcedure? op)
|
||||
(cons (MakeCompiledProcedure-label op)
|
||||
(get-function-entry-and-exit-names (rest stmts)))]
|
||||
[(MakeCompiledProcedureShell? first-stmt)
|
||||
(cons (MakeCompiledProcedureShell-label op)
|
||||
(get-function-entry-and-exit-names (rest stmts)))]
|
||||
[(empty? stmts)
|
||||
'()]
|
||||
[else
|
||||
(define first-stmt (first stmts))
|
||||
(cond
|
||||
[(LinkedLabel? first-stmt)
|
||||
(cons (LinkedLabel-label first-stmt)
|
||||
(cons (LinkedLabel-linked-to first-stmt)
|
||||
(get-function-entry-and-exit-names (rest stmts))))]
|
||||
[(AssignPrimOp? first-stmt)
|
||||
(define op (AssignPrimOp-op first-stmt))
|
||||
(cond
|
||||
[(MakeCompiledProcedure? op)
|
||||
(cons (MakeCompiledProcedure-label op)
|
||||
(get-function-entry-and-exit-names (rest stmts)))]
|
||||
[(MakeCompiledProcedureShell? first-stmt)
|
||||
(cons (MakeCompiledProcedureShell-label op)
|
||||
(get-function-entry-and-exit-names (rest stmts)))]
|
||||
[else
|
||||
(get-function-entry-and-exit-names (rest stmts))])]
|
||||
[else
|
||||
(get-function-entry-and-exit-names (rest stmts))])]
|
||||
[else
|
||||
(get-function-entry-and-exit-names (rest stmts))])]))
|
||||
(get-function-entry-and-exit-names (rest stmts))])]))
|
||||
|
|
|
|||
|
|
@ -7,4 +7,4 @@
|
|||
(provide version)
|
||||
(: version String)
|
||||
|
||||
(define version "1.195")
|
||||
(define version "1.198")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user