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

debugging

Browse Source
This commit is contained in:
dyoo 2011-03-31 14:29:31 -04:00
parent 685e8d0e07
commit 73015f4116
1 changed files with 190 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

235
compile.rkt
View File

@ -358,6 +358,11 @@
(lam+cenv-cenv (first exps))) (lam+cenv-cenv (first exps)))
(compile-lambda-bodies (rest exps)))])) (compile-lambda-bodies (rest exps)))]))
(: extend-compile-time-environment/scratch-space (CompileTimeEnvironment Natural -> CompileTimeEnvironment))
(define (extend-compile-time-environment/scratch-space cenv n)
(append (build-list n (lambda: ([i : Natural])
'?))
cenv))
(: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence))
;; Compiles procedure application ;; Compiles procedure application
@ -367,12 +372,13 @@
;; Known kernel primitive ;; Known kernel primitive
;; In the general case, we do general procedure application. ;; In the general case, we do general procedure application.
(define (compile-application exp cenv target linkage) (define (compile-application exp cenv target linkage)
(let ([extended-cenv (append (map (lambda: ([op : Expression]) (let ([extended-cenv
'?) (extend-compile-time-environment/scratch-space
(App-operands exp)) cenv
cenv)]) (length (App-operands exp)))])
(define (default) (define (default)
(compile-general-application exp cenv extended-cenv target linkage)) (compile-general-application exp cenv target linkage))
(let: ([op-knowledge : CompileTimeEnvironmentEntry (let: ([op-knowledge : CompileTimeEnvironmentEntry
(extract-static-knowledge (App-operator exp) (extract-static-knowledge (App-operator exp)
@ -385,26 +391,28 @@
[(symbol=? (ModuleVariable-module-path op-knowledge) '#%kernel) [(symbol=? (ModuleVariable-module-path op-knowledge) '#%kernel)
(let ([op (ModuleVariable-name op-knowledge)]) (let ([op (ModuleVariable-name op-knowledge)])
(cond [(KernelPrimitiveName? op) (cond [(KernelPrimitiveName? op)
#;(printf "Open coded: ~s\n" (ModuleVariable-name op-knowledge))
(compile-kernel-primitive-application (compile-kernel-primitive-application
op op
exp cenv extended-cenv target linkage)] exp cenv target linkage)]
[else [else
(default)]))] (default)]))]
[else [else
#;(printf "Candidate for open coding: ~s\n" (ModuleVariable-name op-knowledge))
(default)])] (default)])]
[(StaticallyKnownLam? op-knowledge) [(StaticallyKnownLam? op-knowledge)
(compile-statically-known-lam-application op-knowledge exp cenv extended-cenv target linkage)] (compile-statically-known-lam-application op-knowledge exp cenv target linkage)]
[(Prefix? op-knowledge) [(Prefix? op-knowledge)
(error 'impossible)] (error 'impossible)]
[(Const? op-knowledge) [(Const? op-knowledge)
(error 'application "Can't apply constant ~s as a function" (Const-const op-knowledge))])))) (error 'application "Can't apply constant ~s as a function" (Const-const op-knowledge))]))))
(: compile-general-application (App CompileTimeEnvironment CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-general-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-general-application exp cenv extended-cenv target linkage) (define (compile-general-application exp cenv target linkage)
(let ([proc-code (compile (App-operator exp) (let* ([extended-cenv
(extend-compile-time-environment/scratch-space
cenv
(length (App-operands exp)))]
[proc-code (compile (App-operator exp)
extended-cenv extended-cenv
(if (empty? (App-operands exp)) (if (empty? (App-operands exp))
'proc 'proc
@ -435,70 +443,136 @@
(: compile-kernel-primitive-application (: compile-kernel-primitive-application
(KernelPrimitiveName App CompileTimeEnvironment 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.
(define (compile-kernel-primitive-application kernel-op exp cenv extended-cenv target linkage) (define (compile-kernel-primitive-application kernel-op exp cenv target linkage)
(let* ([n (length (App-operands exp))] (let*-values ([(n)
[expected-operand-types (kernel-primitive-expected-operand-types kernel-op n)] (length (App-operands exp))]
[operand-knowledge (map (lambda: ([arg : Expression])
[(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])
(printf "looking up ~s in ~s\n" arg extended-cenv)
(extract-static-knowledge arg extended-cenv)) (extract-static-knowledge arg extended-cenv))
(App-operands exp))] constant-operands)
[typechecks? (map (lambda: ([dom : OperandDomain] (map (lambda: ([arg : Expression])
(printf "looking up ~s in ~s\n" arg extended-cenv)
(extract-static-knowledge arg extended-cenv))
rest-operands))]
[(typechecks?)
(map (lambda: ([dom : OperandDomain]
[known : CompileTimeEnvironmentEntry]) [known : CompileTimeEnvironmentEntry])
(not (redundant-check? dom known))) (not (redundant-check? dom known)))
(kernel-primitive-expected-operand-types kernel-op n) (kernel-primitive-expected-operand-types kernel-op n)
operand-knowledge)]) operand-knowledge)]
(cond
;; Special case optimization: we can avoid touching the stack for constant [(stack-pushing-code)
;; arguments. (if (empty? rest-operands)
[(all-operands-are-constant-or-stack-references (App-operands exp)) empty-instruction-sequence
=> (lambda (opargs) (make-instruction-sequence `(,(make-PushEnvironment
(end-with-linkage (length rest-operands)
linkage cenv #f))))]
(make-instruction-sequence [(stack-popping-code)
`(,(make-AssignPrimOpStatement (if (empty? rest-operands)
target empty-instruction-sequence
(make-CallKernelPrimitiveProcedure kernel-op (make-instruction-sequence `(,(make-PopEnvironment
(map (lambda: ([arg : OpArg]) (length rest-operands)
(adjust-oparg-depth arg (- n))) 0))))]
opargs)
expected-operand-types [(constant-operand-poss)
typechecks?))))))] (constant-operands->opargs constant-operands)]
[else
(let* ([operand-poss [(rest-operand-poss)
(build-list (length (App-operands exp)) (build-list (length rest-operands)
(lambda: ([i : Natural]) (lambda: ([i : Natural])
(make-EnvLexicalReference i #f)))] (make-EnvLexicalReference i #f)))]
[operand-codes (map (lambda: ([operand : Expression] [(rest-operand-code)
(apply append-instruction-sequences
(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) rest-operands
operand-poss)]) 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 (end-with-linkage
linkage cenv linkage cenv
(append-instruction-sequences (append-instruction-sequences
(if (not (empty? (App-operands exp))) stack-pushing-code
(make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f))) rest-operand-code
empty-instruction-sequence)
(apply append-instruction-sequences operand-codes)
(make-instruction-sequence (make-instruction-sequence
`(,(make-AssignPrimOpStatement `(,(make-AssignPrimOpStatement
;; Optimization: we put the result directly in the registers, or in target
;; the appropriate spot on the stack. This takes into account the popenviroment
;; that happens right afterwards.
(adjust-target-depth target n)
(make-CallKernelPrimitiveProcedure kernel-op (make-CallKernelPrimitiveProcedure kernel-op
operand-poss (append constant-operand-poss
rest-operand-poss)
expected-operand-types expected-operand-types
typechecks?)))) typechecks?))))
(if (> n 0) stack-popping-code))))
(make-instruction-sequence `(,(make-PopEnvironment n 0)))
empty-instruction-sequence))))])))
(: ensure-simple-expression (Expression -> (U Constant ToplevelRef LocalRef)))
(define (ensure-simple-expression e)
(if (or (Constant? e)
(LocalRef? e)
(ToplevelRef? e))
e
(error 'ensure-simple-expression)))
(: constant-operands->opargs ((Listof (U Constant LocalRef ToplevelRef))
->
(Listof OpArg)))
;; Produces a list of OpArgs if all the operands are particularly simple, and false therwise.
(define (constant-operands->opargs rands)
(map (lambda: ([e : Expression])
(cond
[(Constant? e)
(make-Const (Constant-v e))]
[(LocalRef? e)
(make-EnvLexicalReference (LocalRef-depth e)
(LocalRef-unbox? e))]
[(ToplevelRef? e)
(make-EnvPrefixReference (ToplevelRef-depth e)
(ToplevelRef-pos e))]
[else
(error 'all-operands-are-constant "Impossible")]))
rands))
(: redundant-check? (OperandDomain CompileTimeEnvironmentEntry -> Boolean)) (: redundant-check? (OperandDomain CompileTimeEnvironmentEntry -> Boolean))
@ -524,38 +598,33 @@
#f])])) #f])]))
(: all-operands-are-constant-or-stack-references ((Listof Expression) -> (U False (Listof OpArg)))) (: split-operands-by-constant-or-stack-references
;; Produces a list of OpArgs if all the operands are particularly simple, and false otherwise. ((Listof Expression) -> (values (Listof (U Constant LocalRef ToplevelRef))
(define (all-operands-are-constant-or-stack-references rands) (Listof Expression))))
(cond [(andmap (lambda: ([rand : Expression]) ;; Splits off the list of operations into two: a prefix of constant
(or (Constant? rand) ;; or simple expressions, and the remainder.
(LocalRef? rand) (define (split-operands-by-constant-or-stack-references rands)
(ToplevelRef? rand))) (let: loop : (values (Listof (U Constant LocalRef ToplevelRef)) (Listof Expression))
rands) ([rands : (Listof Expression) rands]
(map (lambda: ([e : Expression]) [constants : (Listof (U Constant LocalRef ToplevelRef))
(cond empty])
[(Constant? e) (cond [(empty? rands)
(make-Const (Constant-v e))] (values (reverse constants) empty)]
[(LocalRef? e) [else (let ([e (first rands)])
(make-EnvLexicalReference (LocalRef-depth e) (if (or (Constant? e)
(LocalRef-unbox? e))] (LocalRef? e)
[(ToplevelRef? e) (ToplevelRef? e))
(make-EnvPrefixReference (ToplevelRef-depth e) (loop (rest rands) (cons e constants))
(ToplevelRef-pos e))] (values (reverse constants) rands)))])))
[else
(error 'all-operands-are-constant "Impossible")]))
rands)]
[else #f]))
(: compile-statically-known-lam-application (: compile-statically-known-lam-application
(StaticallyKnownLam App CompileTimeEnvironment CompileTimeEnvironment Target Linkage (StaticallyKnownLam App CompileTimeEnvironment Target Linkage
-> InstructionSequence)) -> InstructionSequence))
(define (compile-statically-known-lam-application static-knowledge exp cenv extended-cenv target linkage) (define (compile-statically-known-lam-application static-knowledge exp cenv target linkage)
(unless (= (length (App-operands exp)) (unless (= (length (App-operands exp))
(StaticallyKnownLam-arity static-knowledge)) (StaticallyKnownLam-arity static-knowledge))
(error 'arity-mismatch "~s expected ~s arguments, but received ~s" (error 'arity-mismatch "~s expected ~s arguments, but received ~s"
@ -563,7 +632,11 @@
(StaticallyKnownLam-arity static-knowledge) (StaticallyKnownLam-arity static-knowledge)
(length (App-operands exp)))) (length (App-operands exp))))
(let ([proc-code (compile (App-operator exp) (let* ([extended-cenv
(extend-compile-time-environment/scratch-space
cenv
(length (App-operands exp)))]
[proc-code (compile (App-operator exp)
extended-cenv extended-cenv
(if (empty? (App-operands exp)) (if (empty? (App-operands exp))
'proc 'proc