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

disabling some optimizations; still trying to chase

Browse Source
This commit is contained in:
Danny Yoo 2011-05-17 16:17:10 -04:00
parent fd7fff2c58
commit 24f988c45a
2 changed files with 13 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
compiler.rkt
View File

@ -961,7 +961,7 @@
(ModuleVariable-module-name op-knowledge)) (ModuleVariable-module-name op-knowledge))
'#%kernel) '#%kernel)
(let ([op (ModuleVariable-name op-knowledge)]) (let ([op (ModuleVariable-name op-knowledge)])
(cond [(KernelPrimitiveName/Inline? op) (cond #;[(KernelPrimitiveName/Inline? op)
(compile-kernel-primitive-application (compile-kernel-primitive-application
op op
exp cenv target linkage)] exp cenv target linkage)]
@ -1020,7 +1020,7 @@
linkage)))) linkage))))
(: compile-kernel-primitive-application #;(: compile-kernel-primitive-application
(KernelPrimitiveName/Inline App CompileTimeEnvironment Target Linkage -> InstructionSequence)) (KernelPrimitiveName/Inline 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.
@ -1030,7 +1030,7 @@
;; stack slots, we can do less than that. ;; stack slots, we can do less than that.
;; ;;
;; We have to be sensitive to mutation. ;; 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 ([singular-context-check (emit-singular-context linkage)]) (let ([singular-context-check (emit-singular-context linkage)])
(cond (cond
;; If all the arguments are primitive enough (all constants, localrefs, or toplevelrefs), ;; If all the arguments are primitive enough (all constants, localrefs, or toplevelrefs),
@ -2079,10 +2079,10 @@
(: adjust-expression-depth (Expression Natural Natural -> Expression)) #;(: adjust-expression-depth (Expression Natural Natural -> Expression))
;; Redirects references to the stack to route around a region of size n. ;; Redirects references to the stack to route around a region of size n.
;; The region begins at offset skip into the environment. ;; The region begins at offset skip into the environment.
(define (adjust-expression-depth exp n skip) #;(define (adjust-expression-depth exp n skip)
(cond (cond
[(Top? exp) [(Top? exp)
(make-Top (Top-prefix exp) (make-Top (Top-prefix exp)

11
simulator/simulator.rkt
View File

@ -261,10 +261,16 @@
(let: ([a-top : toplevel (ensure-toplevel (env-ref m (CheckToplevelBound!-depth op)))]) (let: ([a-top : toplevel (ensure-toplevel (env-ref m (CheckToplevelBound!-depth op)))])
(when (> (CheckToplevelBound!-pos op) (when (> (CheckToplevelBound!-pos op)
(length (toplevel-vals a-top))) (length (toplevel-vals a-top)))
(printf "ERROR: toplevel is length ~s, but trying to refer to ~s.\n\n~s" (printf "ERROR: toplevel is length ~s, but trying to refer to ~s.\n\n~s\n"
(length (toplevel-vals a-top)) (length (toplevel-vals a-top))
(CheckToplevelBound!-pos op) (CheckToplevelBound!-pos op)
(toplevel-names a-top))) (toplevel-names a-top))
(for ([i (in-range (length (machine-env m)))])
(let ([elt (env-ref m (ensure-natural i))])
(when (toplevel? elt)
(printf "element ~s ia a toplevel of length ~s\n"
i (length (toplevel-names elt))))))
(flush-output (current-output-port)))
(cond (cond
[(undefined? (list-ref (toplevel-vals a-top) (CheckToplevelBound!-pos op))) [(undefined? (list-ref (toplevel-vals a-top) (CheckToplevelBound!-pos op)))
(error 'check-toplevel-bound! "Unbound identifier ~s" (error 'check-toplevel-bound! "Unbound identifier ~s"
@ -317,7 +323,6 @@
(let: ([a-proc : SlotValue (machine-proc m)]) (let: ([a-proc : SlotValue (machine-proc m)])
(cond (cond
[(closure? a-proc) [(closure? a-proc)
(printf "installing values ~s\n" (closure-vals a-proc))
(env-push-many! m (closure-vals a-proc))] (env-push-many! m (closure-vals a-proc))]
[else [else
(error 'step-perform "Procedure register doesn't hold a procedure: ~s" (error 'step-perform "Procedure register doesn't hold a procedure: ~s"