- improved debugger speed when debug-calling a primitive operation.
Ack now runs only 80 times slower in debug mode (down from 360 times), and bootstrapping is now done in 170 seconds instead of 500 (nondebug time is still less than 8 seconds).
This commit is contained in:
Abdulaziz Ghuloum
parent
ae136274ed
commit
f3b071548d
|
|
@ -65,7 +65,9 @@
|
||||||
[else (error who "invalid closure" x)]))
|
[else (error who "invalid closure" x)]))
|
||||||
;;;
|
;;;
|
||||||
(define (mkfuncall op arg*)
|
(define (mkfuncall op arg*)
|
||||||
(import primops)
|
(define (primop? x)
|
||||||
|
(import primops)
|
||||||
|
(or (eq? x 'debug-call) (primop? x)))
|
||||||
(struct-case op
|
(struct-case op
|
||||||
[(known x t)
|
[(known x t)
|
||||||
(struct-case x
|
(struct-case x
|
||||||
|
|
|
||||||
|
|
@ -1 +1 @@
|
||||||
1786
|
1787
|
||||||
|
|
|
||||||
|
|
@ -52,24 +52,9 @@
|
||||||
(define (interrupt)
|
(define (interrupt)
|
||||||
((interrupt-handler))
|
((interrupt-handler))
|
||||||
(prm 'interrupt))
|
(prm 'interrupt))
|
||||||
(define (primop-interrupt-handler x)
|
(define (with-interrupt-handler p x ctxt args
|
||||||
(case x
|
make-interrupt-call make-no-interrupt-call
|
||||||
[(fx+) 'error@fx+]
|
k)
|
||||||
[(fx-) 'error@fx-]
|
|
||||||
[(fx*) 'error@fx*]
|
|
||||||
[(add1) 'error@add1]
|
|
||||||
[(sub1) 'error@sub1]
|
|
||||||
[(fxadd1) 'error@fxadd1]
|
|
||||||
[(fxsub1) 'error@fxsub1]
|
|
||||||
[(fxarithmetic-shift-left) 'error@fxarithmetic-shift-left]
|
|
||||||
[else x]))
|
|
||||||
(define (make-interrupt-call op args)
|
|
||||||
(make-funcall
|
|
||||||
(V (make-primref (primop-interrupt-handler op)))
|
|
||||||
args))
|
|
||||||
(define (make-no-interrupt-call op args)
|
|
||||||
(make-funcall (V (make-primref op)) args))
|
|
||||||
(define (with-interrupt-handler p x ctxt args k)
|
|
||||||
(cond
|
(cond
|
||||||
[(not (PH-interruptable? p))
|
[(not (PH-interruptable? p))
|
||||||
(parameterize ([interrupt-handler
|
(parameterize ([interrupt-handler
|
||||||
|
|
@ -168,58 +153,90 @@
|
||||||
[(null? lhs*) (k args)]
|
[(null? lhs*) (k args)]
|
||||||
[else
|
[else
|
||||||
(make-bind lhs* rhs* (k args))])))
|
(make-bind lhs* rhs* (k args))])))
|
||||||
(define (cogen-primop x ctxt args)
|
;;;
|
||||||
(define (interrupt? x)
|
(define (make-cogen-handler make-interrupt-call make-no-interrupt-call)
|
||||||
(struct-case x
|
(define (cogen-primop x ctxt args)
|
||||||
[(primcall x) (eq? x 'interrupt)]
|
(define (interrupt? x)
|
||||||
[else #f]))
|
(struct-case x
|
||||||
(let ([p (get-primop x)])
|
[(primcall x) (eq? x 'interrupt)]
|
||||||
(simplify* args
|
[else #f]))
|
||||||
(lambda (args)
|
(let ([p (get-primop x)])
|
||||||
(with-interrupt-handler p x ctxt (map T args)
|
(simplify* args
|
||||||
(lambda ()
|
(lambda (args)
|
||||||
(case ctxt
|
(with-interrupt-handler p x ctxt (map T args)
|
||||||
[(P)
|
make-interrupt-call make-no-interrupt-call
|
||||||
(cond
|
(lambda ()
|
||||||
[(PH-p-handled? p)
|
(case ctxt
|
||||||
(apply (PH-p-handler p) args)]
|
[(P)
|
||||||
[(PH-v-handled? p)
|
(cond
|
||||||
(let ([e (apply (PH-v-handler p) args)])
|
[(PH-p-handled? p)
|
||||||
(if (interrupt? e) e (prm '!= e (K bool-f))))]
|
(apply (PH-p-handler p) args)]
|
||||||
[(PH-e-handled? p)
|
[(PH-v-handled? p)
|
||||||
(let ([e (apply (PH-e-handler p) args)])
|
(let ([e (apply (PH-v-handler p) args)])
|
||||||
(if (interrupt? e) e (make-seq e (K #t))))]
|
(if (interrupt? e) e (prm '!= e (K bool-f))))]
|
||||||
[else (error 'cogen-primop "not handled" x)])]
|
[(PH-e-handled? p)
|
||||||
[(V)
|
(let ([e (apply (PH-e-handler p) args)])
|
||||||
(cond
|
(if (interrupt? e) e (make-seq e (K #t))))]
|
||||||
[(PH-v-handled? p)
|
[else (error 'cogen-primop "not handled" x)])]
|
||||||
(apply (PH-v-handler p) args)]
|
[(V)
|
||||||
[(PH-p-handled? p)
|
(cond
|
||||||
(let ([e (apply (PH-p-handler p) args)])
|
[(PH-v-handled? p)
|
||||||
(if (interrupt? e)
|
(apply (PH-v-handler p) args)]
|
||||||
e
|
[(PH-p-handled? p)
|
||||||
(make-conditional e (K bool-t) (K bool-f))))]
|
(let ([e (apply (PH-p-handler p) args)])
|
||||||
[(PH-e-handled? p)
|
(if (interrupt? e)
|
||||||
(let ([e (apply (PH-e-handler p) args)])
|
e
|
||||||
(if (interrupt? e) e (make-seq e (K void-object))))]
|
(make-conditional e (K bool-t) (K bool-f))))]
|
||||||
[else (error 'cogen-primop "not handled" x)])]
|
[(PH-e-handled? p)
|
||||||
[(E)
|
(let ([e (apply (PH-e-handler p) args)])
|
||||||
(cond
|
(if (interrupt? e) e (make-seq e (K void-object))))]
|
||||||
[(PH-e-handled? p)
|
[else (error 'cogen-primop "not handled" x)])]
|
||||||
(apply (PH-e-handler p) args)]
|
[(E)
|
||||||
[(PH-p-handled? p)
|
(cond
|
||||||
(let ([e (apply (PH-p-handler p) args)])
|
[(PH-e-handled? p)
|
||||||
(if (interrupt? e)
|
(apply (PH-e-handler p) args)]
|
||||||
e
|
[(PH-p-handled? p)
|
||||||
(make-conditional e (prm 'nop) (prm 'nop))))]
|
(let ([e (apply (PH-p-handler p) args)])
|
||||||
[(PH-v-handled? p)
|
(if (interrupt? e)
|
||||||
(let ([e (apply (PH-v-handler p) args)])
|
e
|
||||||
(if (interrupt? e)
|
(make-conditional e (prm 'nop) (prm 'nop))))]
|
||||||
e
|
[(PH-v-handled? p)
|
||||||
(with-tmp ([t e]) (prm 'nop))))]
|
(let ([e (apply (PH-v-handler p) args)])
|
||||||
[else (error 'cogen-primop "not handled" x)])]
|
(if (interrupt? e)
|
||||||
[else
|
e
|
||||||
(error 'cogen-primop "invalid context" ctxt)])))))))
|
(with-tmp ([t e]) (prm 'nop))))]
|
||||||
|
[else (error 'cogen-primop "not handled" x)])]
|
||||||
|
[else
|
||||||
|
(error 'cogen-primop "invalid context" ctxt)])))))))
|
||||||
|
cogen-primop)
|
||||||
|
(module (cogen-primop cogen-debug-primop)
|
||||||
|
(define (primop-interrupt-handler x)
|
||||||
|
(case x
|
||||||
|
[(fx+) 'error@fx+]
|
||||||
|
[(fx-) 'error@fx-]
|
||||||
|
[(fx*) 'error@fx*]
|
||||||
|
[(add1) 'error@add1]
|
||||||
|
[(sub1) 'error@sub1]
|
||||||
|
[(fxadd1) 'error@fxadd1]
|
||||||
|
[(fxsub1) 'error@fxsub1]
|
||||||
|
[(fxarithmetic-shift-left) 'error@fxarithmetic-shift-left]
|
||||||
|
[else x]))
|
||||||
|
(define (make-interrupt-call op args)
|
||||||
|
(make-funcall
|
||||||
|
(V (make-primref (primop-interrupt-handler op)))
|
||||||
|
args))
|
||||||
|
(define (make-no-interrupt-call op args)
|
||||||
|
(make-funcall (V (make-primref op)) args))
|
||||||
|
(define cogen-primop
|
||||||
|
(make-cogen-handler make-interrupt-call make-no-interrupt-call))
|
||||||
|
(define (cogen-debug-primop op src/loc ctxt args)
|
||||||
|
(define (make-call op args)
|
||||||
|
(make-funcall
|
||||||
|
(V (make-primref 'debug-call))
|
||||||
|
(cons* (V src/loc) (V (make-primref op)) args)))
|
||||||
|
((make-cogen-handler make-call make-call)
|
||||||
|
op ctxt args)))
|
||||||
|
|
||||||
|
|
||||||
(define-syntax define-primop
|
(define-syntax define-primop
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
|
|
@ -389,7 +406,10 @@
|
||||||
[(seq e0 e1)
|
[(seq e0 e1)
|
||||||
(make-seq (E e0) (V e1))]
|
(make-seq (E e0) (V e1))]
|
||||||
[(primcall op arg*)
|
[(primcall op arg*)
|
||||||
(cogen-primop op 'V arg*)]
|
(case op
|
||||||
|
[(debug-call)
|
||||||
|
(cogen-debug-call op 'V arg* V)]
|
||||||
|
[else (cogen-primop op 'V arg*)])]
|
||||||
[(forcall op arg*)
|
[(forcall op arg*)
|
||||||
(make-forcall op (map V arg*))]
|
(make-forcall op (map V arg*))]
|
||||||
[(funcall rator arg*)
|
[(funcall rator arg*)
|
||||||
|
|
@ -398,6 +418,20 @@
|
||||||
(make-jmpcall label (V rator) (map V arg*))]
|
(make-jmpcall label (V rator) (map V arg*))]
|
||||||
[else (error 'cogen-V "invalid value expr" x)]))
|
[else (error 'cogen-V "invalid value expr" x)]))
|
||||||
|
|
||||||
|
(define (cogen-debug-call op ctxt arg* k)
|
||||||
|
(define (fail)
|
||||||
|
(k (make-funcall (make-primref 'debug-call) arg*)))
|
||||||
|
(assert (>= (length arg*) 2))
|
||||||
|
(let ([src/expr (car arg*)]
|
||||||
|
[op (cadr arg*)]
|
||||||
|
[args (cddr arg*)])
|
||||||
|
(struct-case (remove-tag op)
|
||||||
|
[(primref name)
|
||||||
|
(if (primop? name)
|
||||||
|
(cogen-debug-primop name src/expr ctxt args)
|
||||||
|
(fail))]
|
||||||
|
[else (fail)])))
|
||||||
|
|
||||||
(define (P x)
|
(define (P x)
|
||||||
(struct-case x
|
(struct-case x
|
||||||
[(constant c) (if c (K #t) (K #f))]
|
[(constant c) (if c (K #t) (K #f))]
|
||||||
|
|
@ -413,7 +447,10 @@
|
||||||
[(fix lhs* rhs* body)
|
[(fix lhs* rhs* body)
|
||||||
(handle-fix lhs* rhs* (P body))]
|
(handle-fix lhs* rhs* (P body))]
|
||||||
[(primcall op arg*)
|
[(primcall op arg*)
|
||||||
(cogen-primop op 'P arg*)]
|
(case op
|
||||||
|
[(debug-call)
|
||||||
|
(cogen-debug-call op 'P arg* P)]
|
||||||
|
[else (cogen-primop op 'P arg*)])]
|
||||||
[(var) (prm '!= (V x) (V (K #f)))]
|
[(var) (prm '!= (V x) (V (K #f)))]
|
||||||
[(funcall) (prm '!= (V x) (V (K #f)))]
|
[(funcall) (prm '!= (V x) (V (K #f)))]
|
||||||
[(jmpcall) (prm '!= (V x) (V (K #f)))]
|
[(jmpcall) (prm '!= (V x) (V (K #f)))]
|
||||||
|
|
@ -439,7 +476,10 @@
|
||||||
[(fix lhs* rhs* body)
|
[(fix lhs* rhs* body)
|
||||||
(handle-fix lhs* rhs* (E body))]
|
(handle-fix lhs* rhs* (E body))]
|
||||||
[(primcall op arg*)
|
[(primcall op arg*)
|
||||||
(cogen-primop op 'E arg*)]
|
(case op
|
||||||
|
[(debug-call)
|
||||||
|
(cogen-debug-call op 'E arg* E)]
|
||||||
|
[else (cogen-primop op 'E arg*)])]
|
||||||
[(forcall op arg*)
|
[(forcall op arg*)
|
||||||
(make-forcall op (map V arg*))]
|
(make-forcall op (map V arg*))]
|
||||||
[(funcall rator arg*)
|
[(funcall rator arg*)
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue