generalizing the optimization
This commit is contained in:
dyoo
parent
074be88089
commit
ad71a72121
380
compile.rkt
380
compile.rkt
|
|
@ -264,23 +264,23 @@
|
|||
(let: ([t-branch : LabelLinkage (make-LabelLinkage (make-label 'trueBranch))]
|
||||
[f-branch : LabelLinkage (make-LabelLinkage (make-label 'falseBranch))]
|
||||
[after-if : LabelLinkage (make-LabelLinkage (make-label 'afterIf))])
|
||||
(let ([consequent-linkage
|
||||
(if (eq? linkage next-linkage)
|
||||
after-if
|
||||
linkage)])
|
||||
(let ([p-code (compile (Branch-predicate exp) cenv 'val next-linkage)]
|
||||
[c-code (compile (Branch-consequent exp) cenv target consequent-linkage)]
|
||||
[a-code (compile (Branch-alternative exp) cenv target linkage)])
|
||||
(append-instruction-sequences p-code
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
`(,(make-TestAndBranchStatement 'false?
|
||||
'val
|
||||
(LabelLinkage-label f-branch))))
|
||||
(append-instruction-sequences
|
||||
(append-instruction-sequences (LabelLinkage-label t-branch) c-code)
|
||||
(append-instruction-sequences (LabelLinkage-label f-branch) a-code))
|
||||
(LabelLinkage-label after-if)))))))
|
||||
(let ([consequent-linkage
|
||||
(if (eq? linkage next-linkage)
|
||||
after-if
|
||||
linkage)])
|
||||
(let ([p-code (compile (Branch-predicate exp) cenv 'val next-linkage)]
|
||||
[c-code (compile (Branch-consequent exp) cenv target consequent-linkage)]
|
||||
[a-code (compile (Branch-alternative exp) cenv target linkage)])
|
||||
(append-instruction-sequences p-code
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
`(,(make-TestAndBranchStatement 'false?
|
||||
'val
|
||||
(LabelLinkage-label f-branch))))
|
||||
(append-instruction-sequences
|
||||
(append-instruction-sequences (LabelLinkage-label t-branch) c-code)
|
||||
(append-instruction-sequences (LabelLinkage-label f-branch) a-code))
|
||||
(LabelLinkage-label after-if)))))))
|
||||
|
||||
|
||||
(: compile-sequence ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
|
|
@ -446,96 +446,145 @@
|
|||
(KernelPrimitiveName App CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
;; This is a special case of application, where the operator is statically
|
||||
;; known to be in the set of hardcoded primitives.
|
||||
;;
|
||||
;; There's a special case optimization we can perform: we can avoid touching
|
||||
;; the stack for constant arguments; rather than allocate (length (App-operands exp))
|
||||
;; stack slots, we can do less than that.
|
||||
;;
|
||||
;; We have to be sensitive to mutation.
|
||||
(define (compile-kernel-primitive-application kernel-op exp cenv target linkage)
|
||||
(let*-values ([(n)
|
||||
(length (App-operands exp))]
|
||||
(cond
|
||||
;; If all the arguments are primitive enough (all constants, localrefs, or toplevelrefs),
|
||||
;; then application requires no stack space at all, and application is especially simple.
|
||||
[(andmap (lambda (op)
|
||||
;; TODO: as long as the operand contains no applications?
|
||||
(or (Constant? op)
|
||||
(ToplevelRef? op)
|
||||
(LocalRef? op)))
|
||||
(App-operands exp))
|
||||
(let* ([n (length (App-operands exp))]
|
||||
|
||||
[(expected-operand-types)
|
||||
(kernel-primitive-expected-operand-types kernel-op n)]
|
||||
[operand-knowledge
|
||||
(map (lambda: ([arg : Expression])
|
||||
(extract-static-knowledge
|
||||
arg
|
||||
(extend-compile-time-environment/scratch-space
|
||||
cenv n)))
|
||||
(App-operands exp))]
|
||||
|
||||
[(constant-operands rest-operands)
|
||||
(split-operands-by-constant-or-stack-references (App-operands exp))]
|
||||
[typechecks?
|
||||
(map (lambda: ([dom : OperandDomain]
|
||||
[known : CompileTimeEnvironmentEntry])
|
||||
(not (redundant-check? dom known)))
|
||||
(kernel-primitive-expected-operand-types kernel-op n)
|
||||
operand-knowledge)]
|
||||
|
||||
;; here, we rewrite the stack references so they assume no scratch space
|
||||
;; used by the constant operands.
|
||||
[(extended-cenv constant-operands rest-operands)
|
||||
(values (extend-compile-time-environment/scratch-space
|
||||
cenv
|
||||
(length rest-operands))
|
||||
[expected-operand-types
|
||||
(kernel-primitive-expected-operand-types kernel-op n)]
|
||||
[operand-poss
|
||||
(simple-operands->opargs (map (lambda: ([op : Expression])
|
||||
(adjust-expression-depth op n n))
|
||||
(App-operands exp)))])
|
||||
(end-with-linkage
|
||||
linkage cenv
|
||||
(make-instruction-sequence
|
||||
`(,(make-AssignPrimOpStatement
|
||||
target
|
||||
(make-CallKernelPrimitiveProcedure
|
||||
kernel-op
|
||||
operand-poss
|
||||
expected-operand-types
|
||||
typechecks?))))))]
|
||||
|
||||
(map (lambda: ([constant-operand : Expression])
|
||||
(ensure-simple-expression
|
||||
(adjust-expression-depth constant-operand
|
||||
(length constant-operands)
|
||||
n)))
|
||||
constant-operands)
|
||||
[else
|
||||
;; Otherwise, we can split the operands into two categories: constants, and the rest.
|
||||
(let*-values ([(n)
|
||||
(length (App-operands exp))]
|
||||
|
||||
(map (lambda: ([rest-operand : Expression])
|
||||
(adjust-expression-depth rest-operand
|
||||
(length constant-operands)
|
||||
n))
|
||||
rest-operands))]
|
||||
[(expected-operand-types)
|
||||
(kernel-primitive-expected-operand-types kernel-op n)]
|
||||
|
||||
[(operand-knowledge)
|
||||
(append (map (lambda: ([arg : Expression])
|
||||
(extract-static-knowledge arg extended-cenv))
|
||||
constant-operands)
|
||||
(map (lambda: ([arg : Expression])
|
||||
(extract-static-knowledge arg extended-cenv))
|
||||
rest-operands))]
|
||||
[(constant-operands rest-operands)
|
||||
(split-operands-by-constant-or-stack-references
|
||||
(App-operands exp))]
|
||||
|
||||
[(typechecks?)
|
||||
(map (lambda: ([dom : OperandDomain]
|
||||
[known : CompileTimeEnvironmentEntry])
|
||||
(not (redundant-check? dom known)))
|
||||
(kernel-primitive-expected-operand-types kernel-op n)
|
||||
operand-knowledge)]
|
||||
;; here, we rewrite the stack references so they assume no scratch space
|
||||
;; used by the constant operands.
|
||||
[(extended-cenv constant-operands rest-operands)
|
||||
(values (extend-compile-time-environment/scratch-space
|
||||
cenv
|
||||
(length rest-operands))
|
||||
|
||||
[(stack-pushing-code)
|
||||
(if (empty? rest-operands)
|
||||
empty-instruction-sequence
|
||||
(make-instruction-sequence `(,(make-PushEnvironment
|
||||
(length rest-operands)
|
||||
#f))))]
|
||||
[(stack-popping-code)
|
||||
(if (empty? rest-operands)
|
||||
empty-instruction-sequence
|
||||
(make-instruction-sequence `(,(make-PopEnvironment
|
||||
(length rest-operands)
|
||||
0))))]
|
||||
(map (lambda: ([constant-operand : Expression])
|
||||
(ensure-simple-expression
|
||||
(adjust-expression-depth constant-operand
|
||||
(length constant-operands)
|
||||
n)))
|
||||
constant-operands)
|
||||
|
||||
[(constant-operand-poss)
|
||||
(constant-operands->opargs constant-operands)]
|
||||
(map (lambda: ([rest-operand : Expression])
|
||||
(adjust-expression-depth rest-operand
|
||||
(length constant-operands)
|
||||
n))
|
||||
rest-operands))]
|
||||
|
||||
[(rest-operand-poss)
|
||||
(build-list (length rest-operands)
|
||||
(lambda: ([i : Natural])
|
||||
(make-EnvLexicalReference i #f)))]
|
||||
[(rest-operand-code)
|
||||
(apply append-instruction-sequences
|
||||
(map (lambda: ([operand : Expression]
|
||||
[target : Target])
|
||||
(compile operand extended-cenv target next-linkage))
|
||||
rest-operands
|
||||
rest-operand-poss))])
|
||||
;; There's a special case optimization we can perform: we can avoid touching
|
||||
;; the stack for constant arguments; rather than allocate (length (App-operands exp))
|
||||
;; stack slots, we can do less than that.
|
||||
[(operand-knowledge)
|
||||
(append (map (lambda: ([arg : Expression])
|
||||
(extract-static-knowledge arg extended-cenv))
|
||||
constant-operands)
|
||||
(map (lambda: ([arg : Expression])
|
||||
(extract-static-knowledge arg extended-cenv))
|
||||
rest-operands))]
|
||||
|
||||
(end-with-linkage
|
||||
linkage cenv
|
||||
(append-instruction-sequences
|
||||
stack-pushing-code
|
||||
rest-operand-code
|
||||
(make-instruction-sequence
|
||||
`(,(make-AssignPrimOpStatement
|
||||
target
|
||||
(make-CallKernelPrimitiveProcedure
|
||||
kernel-op
|
||||
(append constant-operand-poss rest-operand-poss)
|
||||
expected-operand-types
|
||||
typechecks?))))
|
||||
stack-popping-code))))
|
||||
[(typechecks?)
|
||||
(map (lambda: ([dom : OperandDomain]
|
||||
[known : CompileTimeEnvironmentEntry])
|
||||
(not (redundant-check? dom known)))
|
||||
(kernel-primitive-expected-operand-types kernel-op n)
|
||||
operand-knowledge)]
|
||||
|
||||
[(stack-pushing-code)
|
||||
(if (empty? rest-operands)
|
||||
empty-instruction-sequence
|
||||
(make-instruction-sequence `(,(make-PushEnvironment
|
||||
(length rest-operands)
|
||||
#f))))]
|
||||
[(stack-popping-code)
|
||||
(if (empty? rest-operands)
|
||||
empty-instruction-sequence
|
||||
(make-instruction-sequence `(,(make-PopEnvironment
|
||||
(length rest-operands)
|
||||
0))))]
|
||||
|
||||
[(constant-operand-poss)
|
||||
(simple-operands->opargs constant-operands)]
|
||||
|
||||
[(rest-operand-poss)
|
||||
(build-list (length rest-operands)
|
||||
(lambda: ([i : Natural])
|
||||
(make-EnvLexicalReference i #f)))]
|
||||
[(rest-operand-code)
|
||||
(apply append-instruction-sequences
|
||||
(map (lambda: ([operand : Expression]
|
||||
[target : Target])
|
||||
(compile operand extended-cenv target next-linkage))
|
||||
rest-operands
|
||||
rest-operand-poss))])
|
||||
|
||||
(end-with-linkage
|
||||
linkage cenv
|
||||
(append-instruction-sequences
|
||||
stack-pushing-code
|
||||
rest-operand-code
|
||||
(make-instruction-sequence
|
||||
`(,(make-AssignPrimOpStatement
|
||||
(adjust-target-depth target (length rest-operands))
|
||||
(make-CallKernelPrimitiveProcedure
|
||||
kernel-op
|
||||
(append constant-operand-poss rest-operand-poss)
|
||||
expected-operand-types
|
||||
typechecks?))))
|
||||
stack-popping-code)))]))
|
||||
|
||||
|
||||
|
||||
|
|
@ -543,17 +592,15 @@
|
|||
(: ensure-simple-expression (Expression -> (U Constant ToplevelRef LocalRef)))
|
||||
(define (ensure-simple-expression e)
|
||||
(if (or (Constant? e)
|
||||
(LocalRef? e)
|
||||
(ToplevelRef? e))
|
||||
(LocalRef? e)
|
||||
(ToplevelRef? e))
|
||||
e
|
||||
(error 'ensure-simple-expression)))
|
||||
|
||||
|
||||
(: constant-operands->opargs ((Listof (U Constant LocalRef ToplevelRef))
|
||||
->
|
||||
(Listof OpArg)))
|
||||
(: simple-operands->opargs ((Listof Expression) -> (Listof OpArg)))
|
||||
;; Produces a list of OpArgs if all the operands are particularly simple, and false therwise.
|
||||
(define (constant-operands->opargs rands)
|
||||
(define (simple-operands->opargs rands)
|
||||
(map (lambda: ([e : Expression])
|
||||
(cond
|
||||
[(Constant? e)
|
||||
|
|
@ -564,8 +611,8 @@
|
|||
[(ToplevelRef? e)
|
||||
(make-EnvPrefixReference (ToplevelRef-depth e)
|
||||
(ToplevelRef-pos e))]
|
||||
[else
|
||||
(error 'all-operands-are-constant "Impossible")]))
|
||||
[else
|
||||
(error 'all-operands-are-constant "Impossible")]))
|
||||
rands))
|
||||
|
||||
|
||||
|
|
@ -594,8 +641,9 @@
|
|||
|
||||
|
||||
(: split-operands-by-constant-or-stack-references
|
||||
((Listof Expression) -> (values (Listof (U Constant LocalRef ToplevelRef))
|
||||
(Listof Expression))))
|
||||
((Listof Expression) ->
|
||||
(values (Listof (U Constant LocalRef ToplevelRef))
|
||||
(Listof Expression))))
|
||||
;; Splits off the list of operations into two: a prefix of constant
|
||||
;; or simple expressions, and the remainder.
|
||||
(define (split-operands-by-constant-or-stack-references rands)
|
||||
|
|
@ -607,8 +655,12 @@
|
|||
(values (reverse constants) empty)]
|
||||
[else (let ([e (first rands)])
|
||||
(if (or (Constant? e)
|
||||
(LocalRef? e)
|
||||
(ToplevelRef? e))
|
||||
(and (LocalRef? e) (not (LocalRef-unbox? e)))
|
||||
#;(and (ToplevelRef? e)
|
||||
(let ([prefix (ensure-prefix
|
||||
(list-ref cenv (ToplevelRef-depth e)))])
|
||||
(ModuleVariable?
|
||||
(list-ref prefix (ToplevelRef-pos e))))))
|
||||
(loop (rest rands) (cons e constants))
|
||||
(values (reverse constants) rands)))])))
|
||||
|
||||
|
|
@ -631,23 +683,23 @@
|
|||
(extend-compile-time-environment/scratch-space
|
||||
cenv
|
||||
(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)]
|
||||
[operand-codes (map (lambda: ([operand : Expression]
|
||||
[target : Target])
|
||||
(compile operand extended-cenv target next-linkage))
|
||||
(App-operands exp)
|
||||
(build-list (length (App-operands exp))
|
||||
(lambda: ([i : Natural])
|
||||
(if (< i (sub1 (length (App-operands exp))))
|
||||
(make-EnvLexicalReference i #f)
|
||||
'val))))])
|
||||
[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)]
|
||||
[operand-codes (map (lambda: ([operand : Expression]
|
||||
[target : Target])
|
||||
(compile operand extended-cenv target next-linkage))
|
||||
(App-operands exp)
|
||||
(build-list (length (App-operands exp))
|
||||
(lambda: ([i : Natural])
|
||||
(if (< i (sub1 (length (App-operands exp))))
|
||||
(make-EnvLexicalReference i #f)
|
||||
'val))))])
|
||||
(append-instruction-sequences
|
||||
(if (not (empty? (App-operands exp)))
|
||||
(make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f)))
|
||||
|
|
@ -701,38 +753,38 @@
|
|||
(let: ([primitive-branch : LabelLinkage (make-LabelLinkage (make-label 'primitiveBranch))]
|
||||
[compiled-branch : LabelLinkage (make-LabelLinkage (make-label 'compiledBranch))]
|
||||
[after-call : LabelLinkage (make-LabelLinkage (make-label 'afterCall))])
|
||||
(let: ([compiled-linkage : Linkage (if (eq? linkage next-linkage) after-call linkage)])
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
`(,(make-TestAndBranchStatement 'primitive-procedure?
|
||||
'proc
|
||||
(LabelLinkage-label primitive-branch))))
|
||||
(let: ([compiled-linkage : Linkage (if (eq? linkage next-linkage) after-call linkage)])
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
`(,(make-TestAndBranchStatement 'primitive-procedure?
|
||||
'proc
|
||||
(LabelLinkage-label primitive-branch))))
|
||||
|
||||
(LabelLinkage-label compiled-branch)
|
||||
(make-instruction-sequence
|
||||
`(,(make-PerformStatement (make-CheckClosureArity! n))))
|
||||
(end-with-compiled-application-linkage
|
||||
compiled-linkage
|
||||
extended-cenv
|
||||
(compile-proc-appl extended-cenv (make-Reg 'val) n target compiled-linkage))
|
||||
(LabelLinkage-label compiled-branch)
|
||||
(make-instruction-sequence
|
||||
`(,(make-PerformStatement (make-CheckClosureArity! n))))
|
||||
(end-with-compiled-application-linkage
|
||||
compiled-linkage
|
||||
extended-cenv
|
||||
(compile-proc-appl extended-cenv (make-Reg 'val) n target compiled-linkage))
|
||||
|
||||
(LabelLinkage-label primitive-branch)
|
||||
(end-with-linkage
|
||||
linkage
|
||||
cenv
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
`(,(make-AssignPrimOpStatement
|
||||
;; Optimization: we put the result directly in the registers, or in
|
||||
;; the appropriate spot on the stack. This takes into account the popenviroment
|
||||
;; that happens right afterwards.
|
||||
(adjust-target-depth target n)
|
||||
(make-ApplyPrimitiveProcedure n))))
|
||||
(if (not (= n 0))
|
||||
(make-instruction-sequence
|
||||
`(,(make-PopEnvironment n 0)))
|
||||
empty-instruction-sequence)))
|
||||
(LabelLinkage-label after-call)))))
|
||||
(LabelLinkage-label primitive-branch)
|
||||
(end-with-linkage
|
||||
linkage
|
||||
cenv
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
`(,(make-AssignPrimOpStatement
|
||||
;; Optimization: we put the result directly in the registers, or in
|
||||
;; the appropriate spot on the stack. This takes into account the popenviroment
|
||||
;; that happens right afterwards.
|
||||
(adjust-target-depth target n)
|
||||
(make-ApplyPrimitiveProcedure n))))
|
||||
(if (not (= n 0))
|
||||
(make-instruction-sequence
|
||||
`(,(make-PopEnvironment n 0)))
|
||||
empty-instruction-sequence)))
|
||||
(LabelLinkage-label after-call)))))
|
||||
|
||||
|
||||
(: compile-procedure-call/statically-known-lam
|
||||
|
|
@ -740,16 +792,16 @@
|
|||
(define (compile-procedure-call/statically-known-lam static-knowledge extended-cenv n target linkage)
|
||||
(let*: ([after-call : LabelLinkage (make-LabelLinkage (make-label 'afterCall))]
|
||||
[compiled-linkage : Linkage (if (eq? linkage next-linkage) after-call linkage)])
|
||||
(append-instruction-sequences
|
||||
(end-with-compiled-application-linkage
|
||||
compiled-linkage
|
||||
extended-cenv
|
||||
(compile-proc-appl extended-cenv
|
||||
(make-Label (StaticallyKnownLam-entry-point static-knowledge))
|
||||
n
|
||||
target
|
||||
compiled-linkage))
|
||||
(LabelLinkage-label after-call))))
|
||||
(append-instruction-sequences
|
||||
(end-with-compiled-application-linkage
|
||||
compiled-linkage
|
||||
extended-cenv
|
||||
(compile-proc-appl extended-cenv
|
||||
(make-Label (StaticallyKnownLam-entry-point static-knowledge))
|
||||
n
|
||||
target
|
||||
compiled-linkage))
|
||||
(LabelLinkage-label after-call))))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user