mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-02 21:10:27 +02:00
Bailouts can continue directly to tail
* module/language/cps/compile-bytecode.scm (compile-function): Allow a 'throw primcall in tail position. * module/language/cps/prune-bailouts.scm (prune-bailouts): Continue directly to the nearest tail continuation, so we don't cause unreachable handle-interrupts / return 0 instructions to be emitted. * module/language/cps/reify-primitives.scm (reify-clause): Residualized 'throw primcall continues directly to tail. * module/language/cps/verify.scm (check-arities): Relax check for 'throw.
This commit is contained in:
parent
64acf24b40
commit
9db628ee29
4 changed files with 23 additions and 24 deletions
|
@ -125,7 +125,9 @@
|
|||
(for-each (match-lambda
|
||||
((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
|
||||
(lookup-parallel-moves label allocation))
|
||||
(emit-return-values asm (1+ (length args))))))
|
||||
(emit-return-values asm (1+ (length args))))
|
||||
(($ $primcall (or 'throw 'throw/value 'throw/value+data))
|
||||
(compile-effect label exp #f))))
|
||||
|
||||
(define (compile-value label exp dst)
|
||||
(match exp
|
||||
|
|
|
@ -51,23 +51,20 @@ unreferenced terms. In that case TAIL-LABEL is either absent or #f."
|
|||
|
||||
(define (prune-bailouts conts)
|
||||
(let ((tails (compute-tails conts)))
|
||||
(with-fresh-name-state conts
|
||||
(persistent-intmap
|
||||
(intmap-fold
|
||||
(lambda (label cont out)
|
||||
(match cont
|
||||
(($ $kargs names vars
|
||||
($ $continue k src
|
||||
(and exp ($ $primcall
|
||||
(or 'throw 'throw/value 'throw/value+data)))))
|
||||
(match (intmap-ref tails k (lambda (_) #f))
|
||||
(#f out)
|
||||
(ktail
|
||||
(with-cps out
|
||||
(letk knil ($kargs () ()
|
||||
($continue ktail src ($values ()))))
|
||||
(setk label ($kargs names vars
|
||||
($continue knil src ,exp)))))))
|
||||
(_ out)))
|
||||
conts
|
||||
conts)))))
|
||||
(persistent-intmap
|
||||
(intmap-fold
|
||||
(lambda (label cont out)
|
||||
(match cont
|
||||
(($ $kargs names vars
|
||||
($ $continue k src
|
||||
(and exp ($ $primcall
|
||||
(or 'throw 'throw/value 'throw/value+data)))))
|
||||
(match (intmap-ref tails k (lambda (_) #f))
|
||||
(#f out)
|
||||
(ktail
|
||||
(with-cps out
|
||||
(setk label ($kargs names vars
|
||||
($continue ktail src ,exp)))))))
|
||||
(_ out)))
|
||||
conts
|
||||
conts))))
|
||||
|
|
|
@ -100,12 +100,11 @@
|
|||
|
||||
(define (reify-clause cps ktail)
|
||||
(with-cps cps
|
||||
(letk knil ($kargs () () ($continue ktail #f ($values ()))))
|
||||
(let$ body
|
||||
(with-cps-constants ((wna 'wrong-number-of-args)
|
||||
(args '(#f "Wrong number of arguments" () #f)))
|
||||
(build-term
|
||||
($continue knil #f
|
||||
($continue ktail #f
|
||||
($primcall 'throw #f (wna args))))))
|
||||
(letk kbody ($kargs () () ,body))
|
||||
(letk kclause ($kclause ('() '() #f '() #f) kbody #f))
|
||||
|
|
|
@ -255,7 +255,8 @@ definitions that are available at LABEL."
|
|||
(when (false-if-exception (prim-arity name))
|
||||
(error "primitive should continue to $kargs, not $kreceive" name)))
|
||||
(($ $ktail)
|
||||
(error "primitive should continue to $kargs, not $ktail" name))))
|
||||
(unless (memv name '(throw throw/value throw/value+data))
|
||||
(error "primitive should continue to $kargs, not $ktail" name)))))
|
||||
(($ $prompt escape? tag handler)
|
||||
(assert-nullary)
|
||||
(match (intmap-ref conts handler)
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue