[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/02: Remove contification restriction in case-lambda
From: |
Andy Wingo |
Subject: |
[Guile-commits] 02/02: Remove contification restriction in case-lambda |
Date: |
Thu, 9 Mar 2017 08:57:59 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit 7cdfaaada9a9c5a491c393be4cfd475fe61637b8
Author: Andy Wingo <address@hidden>
Date: Thu Mar 9 14:47:42 2017 +0100
Remove contification restriction in case-lambda
* 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.
---
module/language/cps/compile-bytecode.scm | 7 ++++++-
module/language/cps/contification.scm | 36 ++++++--------------------------
2 files changed, 12 insertions(+), 31 deletions(-)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 0524c1e..98d6354 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -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)
diff --git a/module/language/cps/contification.scm
b/module/language/cps/contification.scm
index c08cfbc..f5727f8 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -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))