1
Fork 0
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:
Andy Wingo 2017-12-05 14:25:12 +01:00
parent 64acf24b40
commit 9db628ee29
4 changed files with 23 additions and 24 deletions

View file

@ -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

View file

@ -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))))

View file

@ -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))

View file

@ -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)