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

307
compile.rkt
View File

@ -358,7 +358,12 @@
(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
;; 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.
@ -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,42 +391,44 @@
[(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
extended-cenv (extend-compile-time-environment/scratch-space
(if (empty? (App-operands exp)) cenv
'proc (length (App-operands exp)))]
(make-EnvLexicalReference [proc-code (compile (App-operator exp)
(ensure-natural (sub1 (length (App-operands exp)))) extended-cenv
#f)) (if (empty? (App-operands exp))
next-linkage)] 'proc
[operand-codes (map (lambda: ([operand : Expression] (make-EnvLexicalReference
[target : Target]) (ensure-natural (sub1 (length (App-operands exp))))
(compile operand extended-cenv target next-linkage)) #f))
(App-operands exp) next-linkage)]
(build-list (length (App-operands exp)) [operand-codes (map (lambda: ([operand : Expression]
(lambda: ([i : Natural]) [target : Target])
(if (< i (sub1 (length (App-operands exp)))) (compile operand extended-cenv target next-linkage))
(make-EnvLexicalReference i #f) (App-operands exp)
'val))))]) (build-list (length (App-operands exp))
(lambda: ([i : Natural])
(if (< i (sub1 (length (App-operands exp))))
(make-EnvLexicalReference i #f)
'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)))
@ -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])
(extract-static-knowledge arg extended-cenv)) [(expected-operand-types)
(App-operands exp))] (kernel-primitive-expected-operand-types kernel-op n)]
[typechecks? (map (lambda: ([dom : OperandDomain]
[known : CompileTimeEnvironmentEntry]) [(constant-operands rest-operands)
(not (redundant-check? dom known))) (split-operands-by-constant-or-stack-references (App-operands exp))]
(kernel-primitive-expected-operand-types kernel-op n)
operand-knowledge)]) ;; here, we rewrite the stack references so they assume no scratch space
(cond ;; used by the constant operands.
;; Special case optimization: we can avoid touching the stack for constant [(extended-cenv constant-operands rest-operands)
;; arguments. (values (extend-compile-time-environment/scratch-space
[(all-operands-are-constant-or-stack-references (App-operands exp)) cenv
=> (lambda (opargs) (length rest-operands))
(end-with-linkage
linkage cenv (map (lambda: ([constant-operand : Expression])
(make-instruction-sequence (ensure-simple-expression
`(,(make-AssignPrimOpStatement (adjust-expression-depth constant-operand
target (length constant-operands)
(make-CallKernelPrimitiveProcedure kernel-op n)))
(map (lambda: ([arg : OpArg]) constant-operands)
(adjust-oparg-depth arg (- n)))
opargs) (map (lambda: ([rest-operand : Expression])
expected-operand-types (adjust-expression-depth rest-operand
typechecks?))))))] (length constant-operands)
[else n))
(let* ([operand-poss rest-operands))]
(build-list (length (App-operands exp))
(lambda: ([i : Natural]) [(operand-knowledge)
(make-EnvLexicalReference i #f)))] (append (map (lambda: ([arg : Expression])
[operand-codes (map (lambda: ([operand : Expression] (printf "looking up ~s in ~s\n" arg extended-cenv)
[target : Target]) (extract-static-knowledge arg extended-cenv))
(compile operand extended-cenv target next-linkage)) constant-operands)
(App-operands exp) (map (lambda: ([arg : Expression])
operand-poss)]) (printf "looking up ~s in ~s\n" arg extended-cenv)
(end-with-linkage (extract-static-knowledge arg extended-cenv))
linkage cenv rest-operands))]
(append-instruction-sequences
[(typechecks?)
(if (not (empty? (App-operands exp))) (map (lambda: ([dom : OperandDomain]
(make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f))) [known : CompileTimeEnvironmentEntry])
empty-instruction-sequence) (not (redundant-check? dom known)))
(kernel-primitive-expected-operand-types kernel-op n)
(apply append-instruction-sequences operand-codes) operand-knowledge)]
(make-instruction-sequence [(stack-pushing-code)
`(,(make-AssignPrimOpStatement (if (empty? rest-operands)
;; Optimization: we put the result directly in the registers, or in empty-instruction-sequence
;; the appropriate spot on the stack. This takes into account the popenviroment (make-instruction-sequence `(,(make-PushEnvironment
;; that happens right afterwards. (length rest-operands)
(adjust-target-depth target n) #f))))]
(make-CallKernelPrimitiveProcedure kernel-op [(stack-popping-code)
operand-poss (if (empty? rest-operands)
expected-operand-types empty-instruction-sequence
typechecks?)))) (make-instruction-sequence `(,(make-PopEnvironment
(length rest-operands)
(if (> n 0) 0))))]
(make-instruction-sequence `(,(make-PopEnvironment n 0)))
empty-instruction-sequence))))]))) [(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))))
(: 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