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

generalizing the optimization

Browse Source
This commit is contained in:
dyoo 2011-03-31 15:24:06 -04:00
parent 074be88089
commit ad71a72121
1 changed files with 242 additions and 190 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

380
compile.rkt
View File

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