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

432
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))
@ -363,7 +363,7 @@
(append (build-list n (lambda: ([i : Natural]) (append (build-list n (lambda: ([i : Natural])
'?)) '?))
cenv)) cenv))
(: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence))
;; Compiles procedure application ;; Compiles procedure application
;; Special cases: if we know something about the operator, the compiler will special case. ;; Special cases: if we know something about the operator, the compiler will special case.
@ -376,7 +376,7 @@
(extend-compile-time-environment/scratch-space (extend-compile-time-environment/scratch-space
cenv cenv
(length (App-operands exp)))]) (length (App-operands exp)))])
(define (default) (define (default)
(compile-general-application exp cenv target linkage)) (compile-general-application exp cenv target linkage))
@ -446,114 +446,161 @@
(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.
[(expected-operand-types) [(andmap (lambda (op)
(kernel-primitive-expected-operand-types kernel-op n)] ;; TODO: as long as the operand contains no applications?
(or (Constant? op)
[(constant-operands rest-operands) (ToplevelRef? op)
(split-operands-by-constant-or-stack-references (App-operands exp))] (LocalRef? op)))
(App-operands exp))
;; here, we rewrite the stack references so they assume no scratch space (let* ([n (length (App-operands exp))]
;; used by the constant operands.
[(extended-cenv constant-operands rest-operands) [operand-knowledge
(values (extend-compile-time-environment/scratch-space (map (lambda: ([arg : Expression])
cenv (extract-static-knowledge
(length rest-operands)) arg
(extend-compile-time-environment/scratch-space
(map (lambda: ([constant-operand : Expression]) cenv n)))
(ensure-simple-expression (App-operands exp))]
(adjust-expression-depth constant-operand
(length constant-operands) [typechecks?
n))) (map (lambda: ([dom : OperandDomain]
constant-operands) [known : CompileTimeEnvironmentEntry])
(not (redundant-check? dom known)))
(map (lambda: ([rest-operand : Expression]) (kernel-primitive-expected-operand-types kernel-op n)
(adjust-expression-depth rest-operand operand-knowledge)]
(length constant-operands)
n)) [expected-operand-types
rest-operands))] (kernel-primitive-expected-operand-types kernel-op n)]
[operand-poss
[(operand-knowledge) (simple-operands->opargs (map (lambda: ([op : Expression])
(append (map (lambda: ([arg : Expression]) (adjust-expression-depth op n n))
(extract-static-knowledge arg extended-cenv)) (App-operands exp)))])
constant-operands) (end-with-linkage
(map (lambda: ([arg : Expression]) linkage cenv
(extract-static-knowledge arg extended-cenv)) (make-instruction-sequence
rest-operands))] `(,(make-AssignPrimOpStatement
target
[(typechecks?) (make-CallKernelPrimitiveProcedure
(map (lambda: ([dom : OperandDomain] kernel-op
[known : CompileTimeEnvironmentEntry]) operand-poss
(not (redundant-check? dom known))) expected-operand-types
(kernel-primitive-expected-operand-types kernel-op n) typechecks?))))))]
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)
(constant-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))])
;; 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
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))))
[else
;; Otherwise, we can split the operands into two categories: constants, and the rest.
(let*-values ([(n)
(length (App-operands exp))]
[(expected-operand-types)
(kernel-primitive-expected-operand-types kernel-op n)]
[(constant-operands rest-operands)
(split-operands-by-constant-or-stack-references
(App-operands exp))]
;; 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))
(map (lambda: ([constant-operand : Expression])
(ensure-simple-expression
(adjust-expression-depth constant-operand
(length constant-operands)
n)))
constant-operands)
(map (lambda: ([rest-operand : Expression])
(adjust-expression-depth rest-operand
(length constant-operands)
n))
rest-operands))]
[(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))]
[(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)))]))
(: 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))))
@ -782,7 +834,7 @@
;; only when the target is the val register. ;; only when the target is the val register.
(error 'compile "return linkage, target not val: ~s" target)])] (error 'compile "return linkage, target not val: ~s" target)])]
[(NextLinkage? linkage) [(NextLinkage? linkage)
(cond [(eq? target 'val) (cond [(eq? target 'val)
;; This case happens for a function call that isn't in ;; This case happens for a function call that isn't in
@ -813,7 +865,7 @@
`(,(make-PushControlFrame (LabelLinkage-label linkage)) `(,(make-PushControlFrame (LabelLinkage-label linkage))
,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)) ,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))
,(make-GotoStatement entry-point)))] ,(make-GotoStatement entry-point)))]
[else [else
;; This case happens for evaluating arguments, since the ;; This case happens for evaluating arguments, since the
;; arguments are being installed into the scratch space. ;; arguments are being installed into the scratch space.
@ -1112,7 +1164,7 @@
exp exp
(make-LocalRef (ensure-natural (- (LocalRef-depth exp) n)) (make-LocalRef (ensure-natural (- (LocalRef-depth exp) n))
(LocalRef-unbox? exp)))] (LocalRef-unbox? exp)))]
[(ToplevelSet? exp) [(ToplevelSet? exp)
(if (< (ToplevelSet-depth exp) skip) (if (< (ToplevelSet-depth exp) skip)
(make-ToplevelSet (ToplevelSet-depth exp) (make-ToplevelSet (ToplevelSet-depth exp)
@ -1123,12 +1175,12 @@
(ToplevelSet-pos exp) (ToplevelSet-pos exp)
(ToplevelSet-name exp) (ToplevelSet-name exp)
(adjust-expression-depth (ToplevelSet-value exp) n skip)))] (adjust-expression-depth (ToplevelSet-value exp) n skip)))]
[(Branch? exp) [(Branch? exp)
(make-Branch (adjust-expression-depth (Branch-predicate exp) n skip) (make-Branch (adjust-expression-depth (Branch-predicate exp) n skip)
(adjust-expression-depth (Branch-consequent exp) n skip) (adjust-expression-depth (Branch-consequent exp) n skip)
(adjust-expression-depth (Branch-alternative exp) n skip))] (adjust-expression-depth (Branch-alternative exp) n skip))]
[(Lam? exp) [(Lam? exp)
(make-Lam (Lam-name exp) (make-Lam (Lam-name exp)
(Lam-num-parameters exp) (Lam-num-parameters exp)
@ -1144,7 +1196,7 @@
(make-Seq (map (lambda: ([action : Expression]) (make-Seq (map (lambda: ([action : Expression])
(adjust-expression-depth action n skip)) (adjust-expression-depth action n skip))
(Seq-actions exp)))] (Seq-actions exp)))]
[(App? exp) [(App? exp)
(make-App (adjust-expression-depth (App-operator exp) n (make-App (adjust-expression-depth (App-operator exp) n
(+ skip (length (App-operands exp)))) (+ skip (length (App-operands exp))))
@ -1156,14 +1208,14 @@
[(Let1? exp) [(Let1? exp)
(make-Let1 (adjust-expression-depth (Let1-rhs exp) n (add1 skip)) (make-Let1 (adjust-expression-depth (Let1-rhs exp) n (add1 skip))
(adjust-expression-depth (Let1-body exp) n (add1 skip)))] (adjust-expression-depth (Let1-body exp) n (add1 skip)))]
[(LetVoid? exp) [(LetVoid? exp)
(make-LetVoid (LetVoid-count exp) (make-LetVoid (LetVoid-count exp)
(adjust-expression-depth (LetVoid-body exp) (adjust-expression-depth (LetVoid-body exp)
n n
(+ skip (LetVoid-count exp))) (+ skip (LetVoid-count exp)))
(LetVoid-boxes? exp))] (LetVoid-boxes? exp))]
[(LetRec? exp) [(LetRec? exp)
(make-LetRec (let: loop : (Listof Lam) ([procs : (Listof Lam) (LetRec-procs exp)]) (make-LetRec (let: loop : (Listof Lam) ([procs : (Listof Lam) (LetRec-procs exp)])
(cond (cond
@ -1190,7 +1242,7 @@
n n
skip) skip)
(InstallValue-box? exp)))] (InstallValue-box? exp)))]
[(BoxEnv? exp) [(BoxEnv? exp)
(if (< (BoxEnv-depth exp) skip) (if (< (BoxEnv-depth exp) skip)
(make-BoxEnv (BoxEnv-depth exp) (make-BoxEnv (BoxEnv-depth exp)
@ -1198,4 +1250,4 @@
(make-BoxEnv (ensure-natural (- (BoxEnv-depth exp) n)) (make-BoxEnv (ensure-natural (- (BoxEnv-depth exp) n))
(adjust-expression-depth (BoxEnv-body exp) n skip)))])) (adjust-expression-depth (BoxEnv-body exp) n skip)))]))