mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
$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.
This commit is contained in:
Andy Wingo
parent
de5c81b1d1
commit
ad55ee83c3
26 changed files with 145 additions and 148 deletions
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue