[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 06/08: $throw is a new kind of CPS term
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 06/08: $throw is a new kind of CPS term |
|
Date: |
Wed, 3 Jan 2018 15:31:24 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit ad55ee83c341dc54c3f38bb39004973d0ebbb4ab
Author: Andy Wingo <address@hidden>
Date: Wed Jan 3 18:25:42 2018 +0100
$throw is a new kind of CPS term
* module/language/cps.scm ($throw): New term type that doesn't have a
continuation. Adapt all callers. Remove now-unneeded
"prune-bailouts" pass.
---
am/bootstrap.am | 3 +-
module/Makefile.am | 3 +-
module/language/cps.scm | 15 +++++-
module/language/cps/closure-conversion.scm | 24 +++++++--
module/language/cps/compile-bytecode.scm | 21 +++++---
module/language/cps/contification.scm | 7 ++-
module/language/cps/cse.scm | 18 ++++---
module/language/cps/dce.scm | 18 ++++---
module/language/cps/devirtualize-integers.scm | 9 ++--
module/language/cps/effects-analysis.scm | 3 ++
module/language/cps/licm.scm | 2 +-
module/language/cps/optimize.scm | 5 +-
module/language/cps/peel-loops.scm | 4 +-
module/language/cps/prune-bailouts.scm | 70 ---------------------------
module/language/cps/reify-primitives.scm | 8 ++-
module/language/cps/renumber.scm | 8 ++-
module/language/cps/rotate-loops.scm | 4 +-
module/language/cps/self-references.scm | 4 +-
module/language/cps/simplify.scm | 9 +++-
module/language/cps/slot-allocation.scm | 16 +++---
module/language/cps/specialize-numbers.scm | 4 +-
module/language/cps/split-rec.scm | 4 +-
module/language/cps/types.scm | 6 ++-
module/language/cps/utils.scm | 10 ++--
module/language/cps/verify.scm | 11 ++++-
module/language/tree-il/compile-cps.scm | 7 +--
26 files changed, 145 insertions(+), 148 deletions(-)
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 139649b..2d01206 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -1,5 +1,5 @@
## Copyright (C) 2009, 2010, 2011, 2012, 2013,
-## 2014, 2015, 2017 Free Software Foundation, Inc.
+## 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
##
## This file is part of GNU Guile.
##
@@ -84,7 +84,6 @@ SOURCES = \
language/cps/handle-interrupts.scm \
language/cps/licm.scm \
language/cps/peel-loops.scm \
- language/cps/prune-bailouts.scm \
language/cps/prune-top-level-scopes.scm \
language/cps/reify-primitives.scm \
language/cps/renumber.scm \
diff --git a/module/Makefile.am b/module/Makefile.am
index 535b5d8..b582bbb 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -1,7 +1,7 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 2009, 2010, 2011, 2012, 2013,
-## 2014, 2015, 2017 Free Software Foundation, Inc.
+## 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -142,7 +142,6 @@ SOURCES = \
language/cps/licm.scm \
language/cps/optimize.scm \
language/cps/peel-loops.scm \
- language/cps/prune-bailouts.scm \
language/cps/prune-top-level-scopes.scm \
language/cps/reify-primitives.scm \
language/cps/renumber.scm \
diff --git a/module/language/cps.scm b/module/language/cps.scm
index 771d656..55b34c9 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -127,7 +127,7 @@
$kreceive $kargs $kfun $ktail $kclause
;; Terms.
- $continue $branch $prompt
+ $continue $branch $prompt $throw
;; Expressions.
$const $prim $fun $rec $closure
@@ -181,6 +181,7 @@
(define-cps-type $continue k src exp)
(define-cps-type $branch kf kt src op param args)
(define-cps-type $prompt k kh src escape? tag)
+(define-cps-type $throw src op param args)
;; Expressions.
(define-cps-type $const val)
@@ -231,7 +232,13 @@
((_ ($branch kf kt src op param args))
(make-$branch kf kt src op param args))
((_ ($prompt k kh src escape? tag))
- (make-$prompt k kh src escape? tag))))
+ (make-$prompt k kh src escape? tag))
+ ((_ ($throw src op param (unquote args)))
+ (make-$throw src op param args))
+ ((_ ($throw src op param (arg ...)))
+ (make-$throw src op param (list arg ...)))
+ ((_ ($throw src op param args))
+ (make-$throw src op param args))))
(define-syntax build-exp
(syntax-rules (unquote
@@ -292,6 +299,8 @@
(build-term ($branch kf kt (src exp) op param arg)))
(('prompt k kh escape? tag)
(build-term ($prompt k kh (src exp) escape? tag)))
+ (('throw op param arg ...)
+ (build-term ($throw (src exp) op param arg)))
;; Expressions.
(('unspecified)
@@ -339,6 +348,8 @@
`(branch ,kf ,kt ,op ,param ,@args))
(($ $prompt k kh src escape? tag)
`(prompt ,k ,kh ,escape? ,tag))
+ (($ $throw src op param args)
+ `(throw ,op ,param ,@args))
;; Expressions.
(($ $const val)
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
index 32472f1..2e5a910 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -95,6 +95,8 @@ conts."
(add-uses args uses))
(($ $kargs _ _ ($ $prompt k kh src escape? tag))
(add-use tag uses))
+ (($ $kargs _ _ ($ $throw src op param args))
+ (add-uses args uses))
(_ uses)))
conts
empty-intset)))
@@ -119,7 +121,8 @@ conts."
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
(($ $kargs _ _ ($ $continue k)) (ref1 k))
(($ $kargs _ _ ($ $branch kf kt)) (ref2 kf kt))
- (($ $kargs _ _ ($ $prompt k kh)) (ref2 k kh))))
+ (($ $kargs _ _ ($ $prompt k kh)) (ref2 k kh))
+ (($ $kargs _ _ ($ $throw)) (ref0))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intset-fold add-ref body single multiple)))
(intset-subtract (persistent-intset single)
@@ -253,7 +256,9 @@ shared closures to use the appropriate 'self' variable, if
possible."
(($ $branch kf kt src op param args)
($branch kf kt src op param ,(map subst args)))
(($ $prompt k kh src escape? tag)
- ($prompt k kh src escape? (subst tag)))))
+ ($prompt k kh src escape? (subst tag)))
+ (($ $throw src op param args)
+ ($throw src op param ,(map subst args)))))
(define (visit-rec labels vars cps)
(define (compute-env label bound self rec-bound rec-labels env)
@@ -378,7 +383,9 @@ references."
(($ $branch kf kt src op param args)
(add-uses args uses))
(($ $prompt k kh src escape? tag)
- (add-use tag uses)))))
+ (add-use tag uses))
+ (($ $throw src op param args)
+ (add-uses args uses)))))
(($ $kfun src meta self)
(values (add-def self defs) uses))
(_ (values defs uses))))
@@ -726,6 +733,13 @@ bound to @var{var}, and continue to @var{k}."
(build-term
($continue k src ($values args)))))))
+ (($ $branch kf kt src op param args)
+ (convert-args cps args
+ (lambda (cps args)
+ (with-cps cps
+ (build-term
+ ($branch kf kt src op param args))))))
+
(($ $prompt k kh src escape? tag)
(convert-arg cps tag
(lambda (cps tag)
@@ -733,12 +747,12 @@ bound to @var{var}, and continue to @var{k}."
(build-term
($prompt k kh src escape? tag))))))
- (($ $branch kf kt src op param args)
+ (($ $throw src op param args)
(convert-args cps args
(lambda (cps args)
(with-cps cps
(build-term
- ($branch kf kt src op param args))))))))
+ ($throw src op param args))))))))
(intset-fold (lambda (label cps)
(match (intmap-ref cps label (lambda (_) #f))
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 552f0a4..79459cf 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -125,9 +125,7 @@
(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))))
- (($ $primcall (or 'throw 'throw/value 'throw/value+data))
- (compile-effect label exp #f))))
+ (emit-return-values asm (1+ (length args))))))
(define (compile-value label exp dst)
(match exp
@@ -398,12 +396,15 @@
(($ $primcall 'atomic-box-set! #f (box val))
(emit-atomic-box-set! asm (from-sp (slot box)) (from-sp (slot val))))
(($ $primcall 'handle-interrupts #f ())
- (emit-handle-interrupts asm))
- (($ $primcall 'throw #f (key args))
+ (emit-handle-interrupts asm))))
+
+ (define (compile-throw op param args)
+ (match (vector op param args)
+ (#('throw #f (key args))
(emit-throw asm (from-sp (slot key)) (from-sp (slot args))))
- (($ $primcall 'throw/value param (val))
+ (#('throw/value param (val))
(emit-throw/value asm (from-sp (slot val)) param))
- (($ $primcall 'throw/value+data param (val))
+ (#('throw/value+data param (val))
(emit-throw/value+data asm (from-sp (slot val)) param))))
(define (compile-prompt label k kh escape? tag)
@@ -632,7 +633,11 @@
(($ $prompt k kh src escape? tag)
(when src
(emit-source asm src))
- (compile-prompt label (skip-elided-conts k) kh escape? tag))))
+ (compile-prompt label (skip-elided-conts k) kh escape? tag))
+ (($ $throw src op param args)
+ (when src
+ (emit-source asm src))
+ (compile-throw op param args))))
(define (compile-cont label cont)
(match cont
diff --git a/module/language/cps/contification.scm
b/module/language/cps/contification.scm
index 8266a23..b24d2cb 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -62,7 +62,8 @@ predecessor."
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
(($ $kargs names syms ($ $continue k)) (ref1 k))
(($ $kargs names syms ($ $branch kf kt)) (ref2 kf kt))
- (($ $kargs names syms ($ $prompt k kh)) (ref2 k kh))))
+ (($ $kargs names syms ($ $prompt k kh)) (ref2 k kh))
+ (($ $kargs names syms ($ $throw)) (ref0))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intmap-fold add-ref conts single
multiple)))
(intset-subtract (persistent-intset single)
@@ -194,6 +195,8 @@ $call, and are always called with a compatible arity."
(exclude-vars functions args))
(($ $kargs _ _ ($ $prompt k kh src escape? tag))
(exclude-var functions tag))
+ (($ $kargs _ _ ($ $throw src op param args))
+ (exclude-vars functions args))
(_ functions)))
(intmap-fold visit-cont conts functions)))
@@ -456,7 +459,7 @@ function set."
(match term
(($ $continue k src exp)
(visit-exp cps k src exp))
- ((or ($ $branch) ($ $prompt))
+ ((or ($ $branch) ($ $prompt) ($ $throw))
(with-cps cps term))))
;; Renumbering is not strictly necessary but some passes may not be
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 3591485..2b1a229 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -116,9 +116,10 @@ false. It could be that both true and false proofs are
available."
(match (intmap-ref conts label)
(($ $kargs names vars term)
(match term
- (($ $continue k) (propagate1 k))
+ (($ $continue k) (propagate1 k))
(($ $branch kf kt) (propagate-branch kf kt))
- (($ $prompt k kh) (propagate2 k kh))))
+ (($ $prompt k kh) (propagate2 k kh))
+ (($ $throw) (propagate0))))
(($ $kreceive arity k)
(propagate1 k))
(($ $kfun src meta self tail clause)
@@ -166,8 +167,10 @@ false. It could be that both true and false proofs are
available."
(match (intmap-ref conts k)
(($ $kargs names vars) vars)
(_ #f)))
- ((or ($ $branch) ($ $prompt))
- '())))))
+ (($ $branch)
+ '())
+ ((or ($ $prompt) ($ $throw))
+ #f)))))
(compute-function-body conts kfun)))
(define (compute-singly-referenced succs)
@@ -219,7 +222,7 @@ false. It could be that both true and false proofs are
available."
(($ $values args) #f)))
(($ $branch kf kt src op param args)
(cons* op param (subst-vars var-substs args)))
- (($ $prompt) #f)))
+ ((or ($ $prompt) ($ $throw)) #f)))
(define (add-auxiliary-definitions! label var-substs term-key)
(let ((defs (and=> (intmap-ref defs label)
@@ -402,7 +405,10 @@ false. It could be that both true and false proofs are
available."
($continue k src ,(visit-exp exp))))))
(($ $prompt k kh src escape? tag)
(build-term
- ($prompt k kh src escape? (subst-var tag))))))
+ ($prompt k kh src escape? (subst-var tag))))
+ (($ $throw src op param args)
+ (build-term
+ ($throw src op param ,(map subst-var args))))))
(intmap-map
(lambda (label cont)
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 7fdbfcf..0de6101 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -80,12 +80,10 @@ sites."
(causes-effect? fx &allocation))
(values (intset-add! known k) unknown)
(values known (intset-add! unknown k)))))
- (($ $kargs _ _ ($ $branch))
- ;; Branches pass no values to their
- ;; continuations.
- (values known unknown))
- (($ $kargs _ _ ($ $prompt))
- ;; Likewise for prompts.
+ (($ $kargs _ _ (or ($ $branch) ($ $prompt) ($
$throw)))
+ ;; Branches and prompts pass no values to
+ ;; their continuations, and throw terms don't
+ ;; continue at all.
(values known unknown))
(($ $kreceive arity kargs)
(values known (intset-add! unknown kargs)))
@@ -149,8 +147,6 @@ sites."
(intset-add live-labels kfun)
live-labels)
live-vars)))))
- (($ $prompt escape? tag handler)
- (values live-labels (adjoin-var tag live-vars)))
(($ $call proc args)
(values live-labels (adjoin-vars args (adjoin-var proc live-vars))))
(($ $callk kfun proc args)
@@ -247,6 +243,10 @@ sites."
;; aborts and remove corresponding "unwind" primcalls.
(values (intset-add live-labels label)
(adjoin-var tag live-vars)))
+ (($ $kargs _ _ ($ $throw src op param args))
+ ;; A reachable "throw" is always live.
+ (values (intset-add live-labels label)
+ (adjoin-vars args live-vars)))
(($ $kreceive arity kargs)
(values live-labels live-vars))
(($ $kclause arity kargs kalt)
@@ -356,6 +356,8 @@ sites."
;; (eventually).
(values cps (build-term ($continue kf src ($values ()))))))
(($ $prompt)
+ (values cps term))
+ (($ $throw)
(values cps term))))
(define (visit-cont label cont cps)
(match cont
diff --git a/module/language/cps/devirtualize-integers.scm
b/module/language/cps/devirtualize-integers.scm
index 350e2ae..731089e 100644
--- a/module/language/cps/devirtualize-integers.scm
+++ b/module/language/cps/devirtualize-integers.scm
@@ -76,7 +76,9 @@
(($ $branch kf kt src op param args)
(add-uses use-counts args))
(($ $prompt k kh src escape? tag)
- (add-use use-counts tag))))
+ (add-use use-counts tag))
+ (($ $throw src op param args)
+ (add-uses use-counts args))))
(_ use-counts)))
cps
(transient-intmap))))
@@ -116,10 +118,7 @@ the trace should be referenced outside of it."
vars))))
(define (bailout? k)
(match (intmap-ref cps k)
- (($ $kargs _ _
- ($ $continue _ _
- ($ $primcall (or 'throw 'throw/value 'throw/value+data))))
- #t)
+ (($ $kargs _ _ ($ $throw)) #t)
(_ #f)))
(match (intmap-ref cps label)
;; We know the initial label is a $kargs, and we won't follow the
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index 62cefa0..473b280 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -614,6 +614,9 @@ the LABELS that are clobbered by the effects of LABEL."
;; what nonlocal predecessors of the handler do, so we
;; conservatively assume &all-effects.
&all-effects)
+ (($ $kargs names syms ($ $throw))
+ ;; A reachable "throw" term can never be elided.
+ &all-effects)
(($ $kreceive arity kargs)
(match arity
(($ $arity _ () #f () #f) &type-check)
diff --git a/module/language/cps/licm.scm b/module/language/cps/licm.scm
index b1af1c8..c0768cf 100644
--- a/module/language/cps/licm.scm
+++ b/module/language/cps/licm.scm
@@ -204,7 +204,7 @@
($values fresh-vars))))))
(values cps cont loop-vars loop-effects
pre-header-label always-reached?)))))))))
- (($ $branch)
+ ((or ($ $branch) ($ $throw))
(let* ((cont (build-cont ($kargs names vars ,term)))
(always-reached? #f))
(values cps cont loop-vars loop-effects
diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm
index 8914356..5bbd75f 100644
--- a/module/language/cps/optimize.scm
+++ b/module/language/cps/optimize.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -31,7 +31,6 @@
#:use-module (language cps licm)
#:use-module (language cps peel-loops)
#:use-module (language cps prune-top-level-scopes)
- #:use-module (language cps prune-bailouts)
#:use-module (language cps rotate-loops)
#:use-module (language cps self-references)
#:use-module (language cps simplify)
@@ -92,7 +91,6 @@
(prune-top-level-scopes #:prune-top-level-scopes? #t)
(simplify #:simplify? #t)
(contify #:contify? #t)
- (prune-bailouts #:prune-bailouts? #t)
(simplify #:simplify? #t)
(devirtualize-integers #:devirtualize-integers? #t)
(peel-loops #:peel-loops? #t)
@@ -120,7 +118,6 @@
#:prune-top-level-scopes? #t
#:contify? #t
#:specialize-primcalls? #t
- #:prune-bailouts? #t
#:peel-loops? #t
#:cse? #t
#:type-fold? #t
diff --git a/module/language/cps/peel-loops.scm
b/module/language/cps/peel-loops.scm
index e8144fd..3350c40 100644
--- a/module/language/cps/peel-loops.scm
+++ b/module/language/cps/peel-loops.scm
@@ -152,7 +152,9 @@
op param ,(map rename-var args)))
(($ $prompt k kh src escape? tag)
($prompt (rename-label k) (rename-label kh) src
- escape? (rename-var tag)))))
+ escape? (rename-var tag)))
+ (($ $throw src op param args)
+ ($throw src op param ,(map rename-var args)))))
(rewrite-cont cont
(($ $kargs names vars term)
($kargs names (map rename-var vars) ,(rename-term term)))
diff --git a/module/language/cps/prune-bailouts.scm
b/module/language/cps/prune-bailouts.scm
deleted file mode 100644
index 5d2f7c3..0000000
--- a/module/language/cps/prune-bailouts.scm
+++ /dev/null
@@ -1,70 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; A pass that prunes successors of expressions that bail out.
-;;;
-;;; Code:
-
-(define-module (language cps prune-bailouts)
- #:use-module (ice-9 match)
- #:use-module (language cps)
- #:use-module (language cps utils)
- #:use-module (language cps with-cps)
- #:use-module (language cps intmap)
- #:use-module (language cps intset)
- #:export (prune-bailouts))
-
-(define (compute-tails conts)
- "For each LABEL->CONT entry in the intmap CONTS, compute a
-LABEL->TAIL-LABEL indicating the tail continuation of each expression's
-containing function. In some cases TAIL-LABEL might not be available,
-for example if there is a stale $kfun pointing at a body, or for
-unreferenced terms. In that case TAIL-LABEL is either absent or #f."
- (intmap-fold
- (lambda (label cont out)
- (match cont
- (($ $kfun src meta self tail clause)
- (intset-fold (lambda (label out)
- (intmap-add out label tail (lambda (old new) #f)))
- (compute-function-body conts label)
- out))
- (_ out)))
- conts
- empty-intmap))
-
-(define (prune-bailouts conts)
- (let ((tails (compute-tails 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))))
diff --git a/module/language/cps/reify-primitives.scm
b/module/language/cps/reify-primitives.scm
index afd6f71..51feb6d 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -98,14 +98,12 @@
(build-term
($continue k src ($primcall 'builtin-ref idx ())))))
-(define (reify-clause cps ktail)
+(define (reify-clause cps)
(with-cps cps
(let$ body
(with-cps-constants ((wna 'wrong-number-of-args)
(args '(#f "Wrong number of arguments" () #f)))
- (build-term
- ($continue ktail #f
- ($primcall 'throw #f (wna args))))))
+ (build-term ($throw #f 'throw #f (wna args)))))
(letk kbody ($kargs () () ,body))
(letk kclause ($kclause ('() '() #f '() #f) kbody #f))
kclause))
@@ -233,7 +231,7 @@
(match cont
(($ $kfun src meta self tail #f)
(with-cps cps
- (let$ clause (reify-clause tail))
+ (let$ clause (reify-clause))
(setk label ($kfun src meta self tail clause))))
(($ $kargs names vars ($ $continue k src ($ $prim name)))
(with-cps cps
diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm
index 8adbba9..8b4996e 100644
--- a/module/language/cps/renumber.scm
+++ b/module/language/cps/renumber.scm
@@ -94,7 +94,9 @@
(visit2 kf kt order visited)
(visit2 kt kf order visited)))
(($ $prompt k kh)
- (visit2 k kh order visited))))
+ (visit2 k kh order visited))
+ (($ $throw)
+ (values order visited))))
(($ $kreceive arity k) (visit k order visited))
(($ $kclause arity kbody kalt)
(if kalt
@@ -206,7 +208,9 @@
op param ,(map rename-var args)))
(($ $prompt k kh src escape? tag)
($prompt (rename-label k) (rename-label kh) src
- escape? (rename-var tag))))))
+ escape? (rename-var tag)))
+ (($ $throw src op param args)
+ ($throw src op param ,(map rename-var args))))))
(($ $kreceive ($ $arity req () rest () #f) k)
($kreceive req rest (rename-label k)))
(($ $ktail)
diff --git a/module/language/cps/rotate-loops.scm
b/module/language/cps/rotate-loops.scm
index 4c330f9..48be0d9 100644
--- a/module/language/cps/rotate-loops.scm
+++ b/module/language/cps/rotate-loops.scm
@@ -122,7 +122,9 @@ corresponding var from REPLACEMENTS; otherwise return VAR."
(($ $branch kf kt src op param args)
($branch kf kt src op param ,(rename* args)))
(($ $prompt k kh src escape? tag)
- ($prompt k kh src escape? (rename tag)))))
+ ($prompt k kh src escape? (rename tag)))
+ (($ $throw src op param args)
+ ($throw src op param ,(rename* args)))))
(define (attach-trampoline cps label src names vars args)
(with-cps cps
(letk ktramp-out ,(make-trampoline join-label src args))
diff --git a/module/language/cps/self-references.scm
b/module/language/cps/self-references.scm
index 10fcb7f..63c9d61 100644
--- a/module/language/cps/self-references.scm
+++ b/module/language/cps/self-references.scm
@@ -55,7 +55,9 @@
(($ $branch kf kt src op param args)
($branch kf kt src op param ,(map subst args)))
(($ $prompt k kh src escape? tag)
- ($prompt k kh src escape? (subst tag)))))
+ ($prompt k kh src escape? (subst tag)))
+ (($ $throw src op param args)
+ ($throw src op param ,(map subst args)))))
(define (visit-label label cps)
(match (intmap-ref cps label)
diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm
index a1ac5c9..c50372b 100644
--- a/module/language/cps/simplify.scm
+++ b/module/language/cps/simplify.scm
@@ -82,6 +82,8 @@
(ref* args))
(($ $kargs _ _ ($ $prompt k kh src escape? tag))
(ref tag))
+ (($ $kargs _ _ ($ $throw src op param args))
+ (ref* args))
(_
(values single multiple))))
(let*-values (((single multiple) (values empty-intset empty-intset))
@@ -190,7 +192,8 @@
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
(($ $kargs names syms ($ $continue k)) (ref1 k))
(($ $kargs names syms ($ $branch kf kt)) (ref2 kf kt))
- (($ $kargs names syms ($ $prompt k kh)) (ref2 k kh))))
+ (($ $kargs names syms ($ $prompt k kh)) (ref2 k kh))
+ (($ $kargs names syms ($ $throw)) (ref0))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intset-fold add-ref body single multiple)))
(intset-subtract (persistent-intset single)
@@ -260,7 +263,9 @@
(($ $branch kf kt src op param args)
($branch kf kt src op param ,(map subst args)))
(($ $prompt k kh src escape? tag)
- ($prompt k kh src escape? (subst tag))))))
+ ($prompt k kh src escape? (subst tag)))
+ (($ $throw src op param args)
+ ($throw src op param ,(map subst args))))))
(transform-conts
(lambda (label cont)
(rewrite-cont cont
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index 76cb48d..d74b20d 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -160,6 +160,8 @@ by a label, respectively."
(return empty-intset (vars->intset args)))
(($ $kargs _ _ ($ $prompt k kh src escape? tag))
(return empty-intset (intset tag)))
+ (($ $kargs _ _ ($ $throw src op param args))
+ (return empty-intset (vars->intset args)))
(($ $kclause arity body alt)
(return (get-defs body) empty-intset))
(($ $kreceive arity kargs)
@@ -223,6 +225,7 @@ body continuation in the prompt."
((intset-ref labels label) labels)
(else
(match (intmap-ref conts label)
+ ;; fixme: remove me?
(($ $ktail)
;; Possible for bailouts; never reached and not part of
;; prompt body.
@@ -231,8 +234,6 @@ body continuation in the prompt."
(let ((labels (intset-add! labels label)))
(match cont
(($ $kreceive arity k) (visit-cont k level labels))
- (($ $kargs names syms ($ $prompt k kh src escape? tag))
- (visit-cont kh level (visit-cont k (1+ level) labels)))
(($ $kargs names syms ($ $continue k src ($ $primcall 'wind)))
(visit-cont k (1+ level) labels))
(($ $kargs names syms ($ $continue k src ($ $primcall
'unwind)))
@@ -240,7 +241,10 @@ body continuation in the prompt."
(($ $kargs names syms ($ $continue k src exp))
(visit-cont k level labels))
(($ $kargs names syms ($ $branch kf kt))
- (visit-cont kf level (visit-cont kt level labels))))))))))))
+ (visit-cont kf level (visit-cont kt level labels)))
+ (($ $kargs names syms ($ $prompt k kh src escape? tag))
+ (visit-cont kh level (visit-cont k (1+ level) labels)))
+ (($ $kargs names syms ($ $throw)) labels))))))))))
(define (visit-prompt label handler succs)
(let ((body (compute-prompt-body label)))
(define (out-or-back-edge? label)
@@ -741,10 +745,6 @@ are comparable with eqv?. A tmp slot may be used."
(intmap-fold
(lambda (label cont representations)
(match cont
- (($ $kargs _ _ ($ $branch))
- representations)
- (($ $kargs _ _ ($ $prompt))
- representations)
(($ $kargs _ _ ($ $continue k _ exp))
(match (get-defs k)
(() representations)
@@ -780,6 +780,8 @@ are comparable with eqv?. A tmp slot may be used."
(intmap-add representations var
(intmap-ref representations arg)))
representations args vars))))))
+ (($ $kargs _ _ (or ($ $branch) ($ $prompt) ($ $throw)))
+ representations)
(($ $kfun src meta self)
(intmap-add representations self 'scm))
(($ $kclause arity body alt)
diff --git a/module/language/cps/specialize-numbers.scm
b/module/language/cps/specialize-numbers.scm
index 9c0b895..578a042 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -339,7 +339,9 @@ BITS indicating the significant bits needed for a variable.
BITS may be
(($ $branch kf kt src op param args)
(add-unknown-uses out args))
(($ $prompt k kh src escape? tag)
- (add-unknown-use out tag)))))
+ (add-unknown-use out tag))
+ (($ $throw src op param args)
+ (add-unknown-uses out args)))))
(_ out)))))))))
(define (specialize-operations cps)
diff --git a/module/language/cps/split-rec.scm
b/module/language/cps/split-rec.scm
index a38a889..d58db16 100644
--- a/module/language/cps/split-rec.scm
+++ b/module/language/cps/split-rec.scm
@@ -94,7 +94,9 @@ references."
(($ $branch kf kt src op param args)
(add-uses args uses))
(($ $prompt k kh src escape? tag)
- (add-use tag uses)))))
+ (add-use tag uses))
+ (($ $throw src op param args)
+ (add-uses args uses)))))
(($ $kfun src meta self)
(values (add-def self defs) uses))
(_ (values defs uses))))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index ec74e67..0c9ce84 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1775,9 +1775,9 @@ minimum, and maximum."
(define (successor-count cont)
(match cont
+ (($ $kargs _ _ ($ $throw)) 0)
(($ $kargs _ _ ($ $continue)) 1)
- (($ $kargs _ _ ($ $branch)) 2)
- (($ $kargs _ _ ($ $prompt)) 2)
+ (($ $kargs _ _ (or ($ $branch) ($ $prompt))) 2)
(($ $kfun src meta self tail clause) (if clause 1 0))
(($ $kclause arity body alt) (if alt 2 1))
(($ $kreceive) 1)
@@ -1977,6 +1977,8 @@ maximum, where type is a bitset as a fixnum."
(($ $kargs names vars ($ $prompt k kh src escape? tag))
;; The "normal" continuation enters the prompt.
(propagate2 k types kh types))
+ (($ $kargs names vars ($ $throw))
+ (propagate0))
(($ $kreceive arity k)
(match (intmap-ref conts k)
(($ $kargs names vars)
diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm
index d8e47e1..77431b8 100644
--- a/module/language/cps/utils.scm
+++ b/module/language/cps/utils.scm
@@ -205,7 +205,9 @@ disjoint, an error will be signalled."
(($ $branch kf kt)
(visit-cont kf (visit-cont kt labels)))
(($ $prompt k kh)
- (visit-cont k (visit-cont kh labels))))))))))))
+ (visit-cont k (visit-cont kh labels)))
+ (($ $throw)
+ labels))))))))))
(define* (compute-reachable-functions conts #:optional (kfun 0))
"Compute a mapping LABEL->LABEL..., where each key is a reachable
@@ -262,7 +264,8 @@ intset."
(match term
(($ $continue k) (propagate1 k))
(($ $branch kf kt) (propagate2 kf kt))
- (($ $prompt k kh) (propagate2 k kh))))
+ (($ $prompt k kh) (propagate2 k kh))
+ (($ $throw) (propagate0))))
(($ $kreceive arity k)
(propagate1 k))
(($ $kfun src meta self tail clause)
@@ -296,7 +299,8 @@ intset."
(match term
(($ $continue k) (add-pred k preds))
(($ $branch kf kt) (add-pred kf (add-pred kt preds)))
- (($ $prompt k kh) (add-pred k (add-pred kh preds)))))))
+ (($ $prompt k kh) (add-pred k (add-pred kh preds)))
+ (($ $throw) preds)))))
(persistent-intmap
(intset-fold add-preds labels
(intset->intmap (lambda (label) '()) labels))))
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index 9020c5e..fa3db51 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -107,7 +107,9 @@ definitions that are available at LABEL."
(($ $branch kf kt)
(propagate2 kf kt out))
(($ $prompt k kh)
- (propagate2 k kh out)))))
+ (propagate2 k kh out))
+ (($ $throw)
+ (propagate0 out)))))
(($ $kreceive arity k)
(propagate1 k in))
(($ $kfun src meta self tail clause)
@@ -206,6 +208,9 @@ definitions that are available at LABEL."
first-order)
(($ $prompt k kh src escape? tag)
(check-use tag)
+ first-order)
+ (($ $throw src op param args)
+ (for-each check-use args)
first-order)))
(intmap-fold
(lambda (label bound first-order)
@@ -300,7 +305,9 @@ definitions that are available at LABEL."
(cont (error "bad prompt body" cont)))
(match (intmap-ref conts kh)
(($ $kreceive) #t)
- (cont (error "bad prompt handler" cont))))))
+ (cont (error "bad prompt handler" cont))))
+ (($ $throw)
+ #t)))
(let ((reachable (compute-reachable-labels conts kfun)))
(intmap-for-each
(lambda (label cont)
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index dbdc45c..3424d6c 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -694,18 +694,15 @@
((key . args)
(with-cps cps
(letv arglist)
- (let$ k (adapt-arity k src 0))
(letk kargs ($kargs ('arglist) (arglist)
- ($continue k src
- ($primcall 'throw #f (key arglist)))))
+ ($throw src 'throw #f (key arglist))))
($ (build-list kargs src args))))))))
(define (specialize op param . args)
(convert-args cps args
(lambda (cps args)
(with-cps cps
- (let$ k (adapt-arity k src 0))
(build-term
- ($continue k src ($primcall op param args)))))))
+ ($throw src op param args))))))
(match args
((($ <const> _ key) ($ <const> _ subr) ($ <const> _ msg) args data)
;; Specialize `throw' invocations corresponding to common
- [Guile-commits] branch master updated (108ade6 -> 118f516), Andy Wingo, 2018/01/03
- [Guile-commits] 05/08: Fix add-prompt-control-flow-edges for terms with no continuation, Andy Wingo, 2018/01/03
- [Guile-commits] 02/08: Fix sandbox, Andy Wingo, 2018/01/03
- [Guile-commits] 07/08: Simplify prompt slot allocation now that bailouts can't continue, Andy Wingo, 2018/01/03
- [Guile-commits] 03/08: Variable renaming in type-fold.scm, Andy Wingo, 2018/01/03
- [Guile-commits] 08/08: $primcall always continues to $kargs, Andy Wingo, 2018/01/03
- [Guile-commits] 06/08: $throw is a new kind of CPS term,
Andy Wingo <=
- [Guile-commits] 04/08: $prompt is now its own kind of CPS term., Andy Wingo, 2018/01/03
- [Guile-commits] 01/08: $branch is now a distinct CPS term type, Andy Wingo, 2018/01/03