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

fixing application of statically known lambda so they don't need to juggle

Browse Source
This commit is contained in:
Danny Yoo 2012-02-27 14:27:29 -05:00
parent afaae1dd13
commit b1a09f3e9d
2 changed files with 13 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
compiler/compiler.rkt
View File

@ -1395,29 +1395,21 @@
(: compile-statically-known-lam-application (: compile-statically-known-lam-application
(StaticallyKnownLam App CompileTimeEnvironment Target Linkage (StaticallyKnownLam App CompileTimeEnvironment Target Linkage
-> InstructionSequence)) -> InstructionSequence))
(define (compile-statically-known-lam-application static-knowledge exp cenv target linkage) (define (compile-statically-known-lam-application static-operator-knowledge exp cenv target linkage)
(let ([arity-check (let ([arity-check
(cond [(arity-matches? (StaticallyKnownLam-arity static-knowledge) (cond [(arity-matches? (StaticallyKnownLam-arity static-operator-knowledge)
(length (App-operands exp))) (length (App-operands exp)))
empty-instruction-sequence] empty-instruction-sequence]
[else [else
(make-Perform (make-Perform
(make-RaiseArityMismatchError! (make-RaiseArityMismatchError!
(make-Reg 'proc) (make-Reg 'proc)
(StaticallyKnownLam-arity static-knowledge) (StaticallyKnownLam-arity static-operator-knowledge)
(make-Const (length (App-operands exp)))))])]) (make-Const (length (App-operands exp)))))])])
(let* ([extended-cenv (let* ([extended-cenv
(extend-compile-time-environment/scratch-space (extend-compile-time-environment/scratch-space
cenv cenv
(length (App-operands exp)))] (length (App-operands exp)))]
[proc-code (compile (App-operator exp)
extended-cenv
(if (empty? (App-operands exp))
'proc
(make-EnvLexicalReference
(ensure-natural (sub1 (length (App-operands exp))))
#f))
next-linkage/expects-single)]
[operand-codes (map (lambda: ([operand : Expression] [operand-codes (map (lambda: ([operand : Expression]
[target : Target]) [target : Target])
(compile operand (compile operand
@ -1427,16 +1419,18 @@
(App-operands exp) (App-operands exp)
(build-list (length (App-operands exp)) (build-list (length (App-operands exp))
(lambda: ([i : Natural]) (lambda: ([i : Natural])
(if (< i (sub1 (length (App-operands exp)))) (make-EnvLexicalReference i #f))))]
(make-EnvLexicalReference i #f) [proc-code (compile (App-operator exp)
'val))))]) extended-cenv
'proc
next-linkage/expects-single)])
(append-instruction-sequences (append-instruction-sequences
(make-Comment "scratch space for statically known lambda application") (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)
proc-code proc-code
(juggle-operands operand-codes)
arity-check arity-check
(compile-procedure-call/statically-known-lam static-knowledge (compile-procedure-call/statically-known-lam static-operator-knowledge
cenv cenv
extended-cenv extended-cenv
(length (App-operands exp)) (length (App-operands exp))
@ -1537,7 +1531,7 @@
(: compile-procedure-call/statically-known-lam (: compile-procedure-call/statically-known-lam
(StaticallyKnownLam CompileTimeEnvironment CompileTimeEnvironment Natural Target Linkage -> InstructionSequence)) (StaticallyKnownLam CompileTimeEnvironment CompileTimeEnvironment Natural Target Linkage -> InstructionSequence))
(define (compile-procedure-call/statically-known-lam static-knowledge cenv extended-cenv n target linkage) (define (compile-procedure-call/statically-known-lam static-operator-knowledge cenv extended-cenv n target linkage)
(let*: ([after-call : Symbol (make-label 'afterCall)] (let*: ([after-call : Symbol (make-label 'afterCall)]
[compiled-linkage : Linkage (if (and (ReturnLinkage? linkage) [compiled-linkage : Linkage (if (and (ReturnLinkage? linkage)
(ReturnLinkage-tail? linkage)) (ReturnLinkage-tail? linkage))
@ -1551,7 +1545,7 @@
(compile-compiled-procedure-application cenv (compile-compiled-procedure-application cenv
(make-Const n) (make-Const n)
(make-Label (make-Label
(StaticallyKnownLam-entry-point static-knowledge)) (StaticallyKnownLam-entry-point static-operator-knowledge))
target target
compiled-linkage) compiled-linkage)
(end-with-linkage (end-with-linkage

2
version.rkt
View File

@ -7,4 +7,4 @@
(provide version) (provide version)
(: version String) (: version String)
(define version "1.173") (define version "1.175")