mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +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? (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
frame-size alt) frame-size alt)
;; All arities define a closure binding in slot 0. ;; 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)) (($ $kargs names vars ($ $continue k src exp))
(emit-label asm label) (emit-label asm label)
(for-each (lambda (name var) (for-each (lambda (name var)

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

@ -98,24 +98,6 @@ the set."
conts conts
empty-intmap))) 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) (define (compute-arities conts functions)
"Given the map FUNCTIONS whose keys are $kfun labels, return a map "Given the map FUNCTIONS whose keys are $kfun labels, return a map
from label to arities." 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 functions with known uses that are only ever used as the operator of a
$call, and are always called with a compatible arity." $call, and are always called with a compatible arity."
(let* ((functions (compute-functions conts)) (let* ((functions (compute-functions conts))
(multi-clause (compute-multi-clause conts))
(vars (intmap-fold (lambda (label vars out) (vars (intmap-fold (lambda (label vars out)
(intset-fold (lambda (var out) (intset-fold (lambda (var out)
(intmap-add out var label)) (intmap-add out var label))
@ -191,23 +172,18 @@ $call, and are always called with a compatible arity."
(exclude-vars functions args)) (exclude-vars functions args))
(($ $call proc args) (($ $call proc args)
(let ((functions (exclude-vars functions args))) (let ((functions (exclude-vars functions args)))
;; This contification algorithm is happy to contify the ;; Note that this contification algorithm is happy to
;; `lp' in this example into a shared tail between clauses: ;; contify the `lp' in this example into a shared tail
;; between clauses:
;; ;;
;; (letrec ((lp (lambda () (lp)))) ;; (letrec ((lp (lambda () (lp))))
;; (case-lambda ;; (case-lambda
;; ((a) (lp)) ;; ((a) (lp))
;; ((a b) (lp)))) ;; ((a b) (lp))))
;; ;;
;; However because the current compilation pipeline has to ;; This can cause cross-clause jumps. The rest of the
;; re-nest continuations into old CPS, there would be no ;; compiler handles this fine though, so we allow it.
;; scope in which the tail would be valid. So, until the (restrict-arity functions proc (length args))))
;; 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)))))
(($ $callk k proc args) (($ $callk k proc args)
(exclude-vars functions (cons proc args))) (exclude-vars functions (cons proc args)))
(($ $branch kt ($ $primcall name args)) (($ $branch kt ($ $primcall name args))