mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 22:10:21 +02:00
Code Activity

Remove contification restriction in case-lambda

Browse source 
* module/language/cps/compile-bytecode.scm (compile-function): Check for
  fallthrough after $kclause too; possible to need to jump if clause
  tails are contified.
* module/language/cps/contification.scm (compute-contification-candidates):
  Enable inter-clause contification.
This commit is contained in:
Andy Wingo 2017-03-09 14:47:42 +01:00
parent 6d9335ad46
commit 7cdfaaada9
2 changed files with 12 additions and 31 deletions
Download patch file Download diff file Expand all files Collapse all files

7
module/language/cps/compile-bytecode.scm
View file

@ -553,7 +553,12 @@
(emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
frame-size alt)
;; All arities define a closure binding in slot 0.
(emit-definition asm 'closure 0 'scm)))
(emit-definition asm 'closure 0 'scm)
;; Usually we just fall through, but it could be the body is
;; contified into another clause.
(let ((body (forward-label body)))
(unless (= body (skip-elided-conts (1+ label)))
(emit-br asm body)))))
(($ $kargs names vars ($ $continue k src exp))
(emit-label asm label)
(for-each (lambda (name var)

36
module/language/cps/contification.scm
View file

@ -98,24 +98,6 @@ the set."
conts
empty-intmap)))
(define (compute-multi-clause conts)
"Compute an set containing all labels that are part of a multi-clause
case-lambda. See the note in compute-contification-candidates."
(define (multi-clause? clause)
(and clause
(match (intmap-ref conts clause)
(($ $kclause arity body alt)
alt))))
(intmap-fold (lambda (label cont multi)
(match cont
(($ $kfun src meta self tail clause)
(if (multi-clause? clause)
(intset-union multi (compute-function-body conts label))
multi))
(_ multi)))
conts
empty-intset))
(define (compute-arities conts functions)
"Given the map FUNCTIONS whose keys are $kfun labels, return a map
from label to arities."
@ -152,7 +134,6 @@ from label to arities."
functions with known uses that are only ever used as the operator of a
$call, and are always called with a compatible arity."
(let* ((functions (compute-functions conts))
(multi-clause (compute-multi-clause conts))
(vars (intmap-fold (lambda (label vars out)
(intset-fold (lambda (var out)
(intmap-add out var label))
@ -191,23 +172,18 @@ $call, and are always called with a compatible arity."
(exclude-vars functions args))
(($ $call proc args)
(let ((functions (exclude-vars functions args)))
;; This contification algorithm is happy to contify the
;; `lp' in this example into a shared tail between clauses:
;; Note that this contification algorithm is happy to
;; contify the `lp' in this example into a shared tail
;; between clauses:
;;
;; (letrec ((lp (lambda () (lp))))
;; (case-lambda
;; ((a) (lp))
;; ((a b) (lp))))
;;
;; However because the current compilation pipeline has to
;; re-nest continuations into old CPS, there would be no
;; scope in which the tail would be valid. So, until the
;; old compilation pipeline is completely replaced,
;; conservatively exclude contifiable fucntions called
;; from multi-clause procedures.
(if (intset-ref multi-clause label)
(exclude-var functions proc)
(restrict-arity functions proc (length args)))))
;; This can cause cross-clause jumps. The rest of the
;; compiler handles this fine though, so we allow it.
(restrict-arity functions proc (length args))))
(($ $callk k proc args)
(exclude-vars functions (cons proc args)))
(($ $branch kt ($ $primcall name args))