[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/08: $branch is now a distinct CPS term type
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/08: $branch is now a distinct CPS term type |
|
Date: |
Wed, 3 Jan 2018 15:31:23 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit afb0a92d501af0c2ffa5428a35171ba40782f8ca
Author: Andy Wingo <address@hidden>
Date: Wed Jan 3 14:15:35 2018 +0100
$branch is now a distinct CPS term type
* module/language/cps.scm ($branch): Refactor to be its own CPS term
type, not relying on $continue to specify a continuation (which before
was only for the false case) or a source location. Update allllllll
callers.
---
.dir-locals.el | 1 +
module/language/cps.scm | 35 +++---
module/language/cps/closure-conversion.scm | 161 +++++++++++++-------------
module/language/cps/compile-bytecode.scm | 156 +++++++++++++------------
module/language/cps/contification.scm | 22 +++-
module/language/cps/cse.scm | 147 ++++++++++++-----------
module/language/cps/dce.scm | 61 ++++++----
module/language/cps/devirtualize-integers.scm | 158 +++++++++++++------------
module/language/cps/effects-analysis.scm | 6 +-
module/language/cps/handle-interrupts.scm | 20 ++--
module/language/cps/licm.scm | 156 +++++++++++++------------
module/language/cps/peel-loops.scm | 16 ++-
module/language/cps/reify-primitives.scm | 8 +-
module/language/cps/renumber.scm | 57 ++++-----
module/language/cps/rotate-loops.scm | 135 +++++++++++----------
module/language/cps/self-references.scm | 64 +++++-----
module/language/cps/simplify.scm | 72 ++++++------
module/language/cps/slot-allocation.scm | 36 +++---
module/language/cps/specialize-numbers.scm | 120 ++++++++-----------
module/language/cps/split-rec.scm | 46 ++++----
module/language/cps/type-checks.scm | 16 ++-
module/language/cps/type-fold.scm | 49 ++++----
module/language/cps/types.scm | 14 +--
module/language/cps/utils.scm | 44 ++++---
module/language/cps/verify.scm | 86 +++++++++++---
module/language/tree-il/compile-cps.scm | 19 ++-
26 files changed, 904 insertions(+), 801 deletions(-)
diff --git a/.dir-locals.el b/.dir-locals.el
index 5e213c5..3fdf789 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -33,6 +33,7 @@
(eval . (put '$letk* 'scheme-indent-function 1))
(eval . (put '$letconst 'scheme-indent-function 1))
(eval . (put '$continue 'scheme-indent-function 2))
+ (eval . (put '$branch 'scheme-indent-function 3))
(eval . (put '$kargs 'scheme-indent-function 2))
(eval . (put '$kfun 'scheme-indent-function 4))
(eval . (put '$letrec 'scheme-indent-function 3))
diff --git a/module/language/cps.scm b/module/language/cps.scm
index eae5fdc..ddd4102 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.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
@@ -127,10 +127,10 @@
$kreceive $kargs $kfun $ktail $kclause
;; Terms.
- $continue
+ $continue $branch
;; Expressions.
- $const $prim $fun $rec $closure $branch
+ $const $prim $fun $rec $closure
$call $callk $primcall $values $prompt
;; Building macros.
@@ -179,6 +179,7 @@
;; Terms.
(define-cps-type $continue k src exp)
+(define-cps-type $branch kf kt src op param args)
;; Expressions.
(define-cps-type $const val)
@@ -186,7 +187,6 @@
(define-cps-type $fun body) ; Higher-order.
(define-cps-type $rec names syms funs) ; Higher-order.
(define-cps-type $closure label nfree) ; First-order.
-(define-cps-type $branch kt exp)
(define-cps-type $call proc args)
(define-cps-type $callk k proc args) ; First-order.
(define-cps-type $primcall name param args)
@@ -223,11 +223,17 @@
((_ (unquote exp))
exp)
((_ ($continue k src exp))
- (make-$continue k src (build-exp exp)))))
+ (make-$continue k src (build-exp exp)))
+ ((_ ($branch kf kt src op param (unquote args)))
+ (make-$branch kf kt src op param args))
+ ((_ ($branch kf kt src op param (arg ...)))
+ (make-$branch kf kt src op param (list arg ...)))
+ ((_ ($branch kf kt src op param args))
+ (make-$branch kf kt src op param args))))
(define-syntax build-exp
(syntax-rules (unquote
- $const $prim $fun $rec $closure $branch
+ $const $prim $fun $rec $closure
$call $callk $primcall $values $prompt)
((_ (unquote exp)) exp)
((_ ($const val)) (make-$const val))
@@ -247,7 +253,6 @@
((_ ($values (unquote args))) (make-$values args))
((_ ($values (arg ...))) (make-$values (list arg ...)))
((_ ($values args)) (make-$values args))
- ((_ ($branch kt exp)) (make-$branch kt (build-exp exp)))
((_ ($prompt escape? tag handler))
(make-$prompt escape? tag handler))))
@@ -280,9 +285,13 @@
(('kclause (req opt rest kw allow-other-keys?) kbody kalt)
(build-cont ($kclause (req opt rest kw allow-other-keys?) kbody kalt)))
- ;; Calls.
+ ;; Terms.
(('continue k exp)
(build-term ($continue k (src exp) ,(parse-cps exp))))
+ (('branch kf kt op param arg ...)
+ (build-term ($branch kf kt (src exp) op param arg)))
+
+ ;; Expressions.
(('unspecified)
(build-exp ($const *unspecified*)))
(('const exp)
@@ -301,8 +310,6 @@
(build-exp ($callk k proc arg)))
(('primcall name param arg ...)
(build-exp ($primcall name param arg)))
- (('branch k exp)
- (build-exp ($branch k ,(parse-cps exp))))
(('values arg ...)
(build-exp ($values arg)))
(('prompt escape? tag handler)
@@ -325,9 +332,13 @@
`(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,kbody
. ,(if kalternate (list kalternate) '())))
- ;; Calls.
+ ;; Terms.
(($ $continue k src exp)
`(continue ,k ,(unparse-cps exp)))
+ (($ $branch kf kt src op param args)
+ `(branch ,kf ,kt ,op ,param ,@args))
+
+ ;; Expressions.
(($ $const val)
(if (unspecified? val)
'(unspecified)
@@ -348,8 +359,6 @@
`(callk ,k ,proc ,@args))
(($ $primcall name param args)
`(primcall ,name ,param ,@args))
- (($ $branch k exp)
- `(branch ,k ,(unparse-cps exp)))
(($ $values args)
`(values ,@args))
(($ $prompt escape? tag handler)
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
index 58f0020..b15bb63 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.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
@@ -89,12 +89,12 @@ conts."
(add-uses args uses))
(($ $call proc args)
(add-uses args uses))
- (($ $branch kt ($ $primcall name param args))
- (add-uses args uses))
(($ $primcall name param args)
(add-uses args uses))
(($ $prompt escape? tag handler)
(add-use tag uses))))
+ (($ $kargs _ _ ($ $branch kf kt src op param args))
+ (add-uses args uses))
(_ uses)))
conts
empty-intset)))
@@ -117,8 +117,9 @@ conts."
(($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
(($ $ktail) (ref0))
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
- (($ $kargs names syms ($ $continue k src exp))
- (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f))))))
+ (($ $kargs _ _ ($ $continue k _ ($ $prompt _ _ h))) (ref2 k h))
+ (($ $kargs _ _ ($ $continue k)) (ref1 k))
+ (($ $kargs _ _ ($ $branch kf kt)) (ref2 kf kt))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intset-fold add-ref body single multiple)))
(intset-subtract (persistent-intset single)
@@ -226,35 +227,35 @@ proc argument. For recursive calls, use the appropriate
'self'
variable, if possible. Also rewrite uses of the non-well-known but
shared closures to use the appropriate 'self' variable, if possible."
;; env := var -> (var . label)
- (define (rewrite-fun kfun cps env)
+ (define (visit-fun kfun cps env)
(define (subst var)
(match (intmap-ref env var (lambda (_) #f))
(#f var)
((var . label) var)))
- (define (rename-exp label cps names vars k src exp)
- (intmap-replace!
- cps label
- (build-cont
- ($kargs names vars
- ($continue k src
- ,(rewrite-exp exp
- ((or ($ $const) ($ $prim)) ,exp)
- (($ $call proc args)
- ,(let ((args (map subst args)))
- (rewrite-exp (intmap-ref env proc (lambda (_) #f))
- (#f ($call proc ,args))
- ((closure . label) ($callk label closure ,args)))))
- (($ $primcall name param args)
- ($primcall name param ,(map subst args)))
- (($ $branch k ($ $primcall name param args))
- ($branch k ($primcall name param ,(map subst args))))
- (($ $values args)
- ($values ,(map subst args)))
- (($ $prompt escape? tag handler)
- ($prompt escape? (subst tag) handler))))))))
-
- (define (visit-exp label cps names vars k src exp)
+ (define (visit-exp exp)
+ (rewrite-exp exp
+ ((or ($ $const) ($ $prim)) ,exp)
+ (($ $call proc args)
+ ,(let ((args (map subst args)))
+ (rewrite-exp (intmap-ref env proc (lambda (_) #f))
+ (#f ($call proc ,args))
+ ((closure . label) ($callk label closure ,args)))))
+ (($ $primcall name param args)
+ ($primcall name param ,(map subst args)))
+ (($ $values args)
+ ($values ,(map subst args)))
+ (($ $prompt escape? tag handler)
+ ($prompt escape? (subst tag) handler))))
+
+ (define (visit-term term)
+ (rewrite-term term
+ (($ $continue k src exp)
+ ($continue k src ,(visit-exp exp)))
+ (($ $branch kf kt src op param args)
+ ($branch kf kt src op param ,(map subst args)))))
+
+ (define (visit-rec labels vars cps)
(define (compute-env label bound self rec-bound rec-labels env)
(define (add-bound-var bound label env)
(intmap-add env bound (cons self label) (lambda (old new) new)))
@@ -265,26 +266,27 @@ shared closures to use the appropriate 'self' variable,
if possible."
;; Otherwise be sure to use "self" references in any
;; closure.
(add-bound-var bound label env)))
- (match exp
- (($ $fun label)
- (rewrite-fun label cps env))
- (($ $rec names vars (($ $fun labels) ...))
- (fold (lambda (label var cps)
- (match (intmap-ref cps label)
- (($ $kfun src meta self)
- (rewrite-fun label cps
- (compute-env label var self vars labels
- env)))))
- cps labels vars))
- (_ (rename-exp label cps names vars k src exp))))
-
- (define (rewrite-cont label cps)
+ (fold (lambda (label var cps)
+ (match (intmap-ref cps label)
+ (($ $kfun src meta self)
+ (visit-fun label cps
+ (compute-env label var self vars labels env)))))
+ cps labels vars))
+
+ (define (visit-cont label cps)
(match (intmap-ref cps label)
- (($ $kargs names vars ($ $continue k src exp))
- (visit-exp label cps names vars k src exp))
+ (($ $kargs names vars
+ ($ $continue k src ($ $fun label)))
+ (visit-fun label cps env))
+ (($ $kargs _ _
+ ($ $continue k src ($ $rec names vars (($ $fun labels) ...))))
+ (visit-rec labels vars cps))
+ (($ $kargs names vars term)
+ (with-cps cps
+ (setk label ($kargs names vars ,(visit-term term)))))
(_ cps)))
- (intset-fold rewrite-cont (intmap-ref functions kfun) cps))
+ (intset-fold visit-cont (intmap-ref functions kfun) cps))
;; Initial environment is bound-var -> (shared-var . label) map for
;; functions with shared closures.
@@ -299,7 +301,7 @@ shared closures to use the appropriate 'self' variable, if
possible."
env))
shared
empty-intmap)))
- (persistent-intmap (rewrite-fun kfun cps env))))
+ (persistent-intmap (visit-fun kfun cps env))))
(define (compute-free-vars conts kfun shared)
"Compute a FUN-LABEL->FREE-VAR... map describing all free variable
@@ -350,31 +352,33 @@ references."
(intset-fold
(lambda (label defs uses)
(match (intmap-ref conts label)
- (($ $kargs names vars ($ $continue k src exp))
+ (($ $kargs names vars term)
(values
(add-defs vars defs)
- (match exp
- ((or ($ $const) ($ $prim)) uses)
- (($ $fun kfun)
- (intset-union (persistent-intset uses)
- (intmap-ref free kfun)))
- (($ $rec names vars (($ $fun kfun) ...))
- (fold (lambda (kfun uses)
- (intset-union (persistent-intset uses)
- (intmap-ref free kfun)))
- uses kfun))
- (($ $values args)
- (add-uses args uses))
- (($ $call proc args)
- (add-use proc (add-uses args uses)))
- (($ $callk label proc args)
- (add-use proc (add-uses args uses)))
- (($ $branch kt ($ $primcall name param args))
- (add-uses args uses))
- (($ $primcall name param args)
- (add-uses args uses))
- (($ $prompt escape? tag handler)
- (add-use tag uses)))))
+ (match term
+ (($ $continue k src exp)
+ (match exp
+ ((or ($ $const) ($ $prim)) uses)
+ (($ $fun kfun)
+ (intset-union (persistent-intset uses)
+ (intmap-ref free kfun)))
+ (($ $rec names vars (($ $fun kfun) ...))
+ (fold (lambda (kfun uses)
+ (intset-union (persistent-intset uses)
+ (intmap-ref free kfun)))
+ uses kfun))
+ (($ $values args)
+ (add-uses args uses))
+ (($ $call proc args)
+ (add-use proc (add-uses args uses)))
+ (($ $callk label proc args)
+ (add-use proc (add-uses args uses)))
+ (($ $primcall name param args)
+ (add-uses args uses))
+ (($ $prompt escape? tag handler)
+ (add-use tag uses))))
+ (($ $branch kf kt src op param args)
+ (add-uses args uses)))))
(($ $kfun src meta self)
(values (add-def self defs) uses))
(_ (values defs uses))))
@@ -715,14 +719,6 @@ bound to @var{var}, and continue to @var{k}."
(build-term
($continue k src ($primcall name param args)))))))
- (($ $continue k src ($ $branch kt ($ $primcall name param args)))
- (convert-args cps args
- (lambda (cps args)
- (with-cps cps
- (build-term
- ($continue k src
- ($branch kt ($primcall name param args))))))))
-
(($ $continue k src ($ $values args))
(convert-args cps args
(lambda (cps args)
@@ -736,7 +732,14 @@ bound to @var{var}, and continue to @var{k}."
(with-cps cps
(build-term
($continue k src
- ($prompt escape? tag handler)))))))))
+ ($prompt escape? tag handler)))))))
+
+ (($ $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))))))))
(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 2b3b23f..0bef330 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.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
@@ -435,7 +435,7 @@
((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation)))))
- (define (compile-test label exp kt kf next-label)
+ (define (compile-test label next-label kf kt op param args)
(define (prefer-true?)
(if (< (max kt kf) label)
;; Two backwards branches. Prefer
@@ -474,71 +474,71 @@
(define (binary-</imm op a b)
(op asm (from-sp (slot a)) b)
(emit-branch emit-jl emit-jnl))
- (match exp
+ (match (vector op param args)
;; Immediate type tag predicates.
- (($ $primcall 'fixnum? #f (a)) (unary emit-fixnum? a))
- (($ $primcall 'heap-object? #f (a)) (unary emit-heap-object? a))
- (($ $primcall 'char? #f (a)) (unary emit-char? a))
- (($ $primcall 'eq-false? #f (a)) (unary emit-eq-false? a))
- (($ $primcall 'eq-nil? #f (a)) (unary emit-eq-nil? a))
- (($ $primcall 'eq-null? #f (a)) (unary emit-eq-null? a))
- (($ $primcall 'eq-true? #f (a)) (unary emit-eq-true? a))
- (($ $primcall 'unspecified? #f (a)) (unary emit-unspecified? a))
- (($ $primcall 'undefined? #f (a)) (unary emit-undefined? a))
- (($ $primcall 'eof-object? #f (a)) (unary emit-eof-object? a))
- (($ $primcall 'null? #f (a)) (unary emit-null? a))
- (($ $primcall 'false? #f (a)) (unary emit-false? a))
- (($ $primcall 'nil? #f (a)) (unary emit-nil? a))
+ (#('fixnum? #f (a)) (unary emit-fixnum? a))
+ (#('heap-object? #f (a)) (unary emit-heap-object? a))
+ (#('char? #f (a)) (unary emit-char? a))
+ (#('eq-false? #f (a)) (unary emit-eq-false? a))
+ (#('eq-nil? #f (a)) (unary emit-eq-nil? a))
+ (#('eq-null? #f (a)) (unary emit-eq-null? a))
+ (#('eq-true? #f (a)) (unary emit-eq-true? a))
+ (#('unspecified? #f (a)) (unary emit-unspecified? a))
+ (#('undefined? #f (a)) (unary emit-undefined? a))
+ (#('eof-object? #f (a)) (unary emit-eof-object? a))
+ (#('null? #f (a)) (unary emit-null? a))
+ (#('false? #f (a)) (unary emit-false? a))
+ (#('nil? #f (a)) (unary emit-nil? a))
;; Heap type tag predicates.
- (($ $primcall 'pair? #f (a)) (unary emit-pair? a))
- (($ $primcall 'struct? #f (a)) (unary emit-struct? a))
- (($ $primcall 'symbol? #f (a)) (unary emit-symbol? a))
- (($ $primcall 'variable? #f (a)) (unary emit-variable? a))
- (($ $primcall 'vector? #f (a)) (unary emit-vector? a))
- (($ $primcall 'string? #f (a)) (unary emit-string? a))
- (($ $primcall 'heap-number? #f (a)) (unary emit-heap-number? a))
- (($ $primcall 'hash-table? #f (a)) (unary emit-hash-table? a))
- (($ $primcall 'pointer? #f (a)) (unary emit-pointer? a))
- (($ $primcall 'fluid? #f (a)) (unary emit-fluid? a))
- (($ $primcall 'stringbuf? #f (a)) (unary emit-stringbuf? a))
- (($ $primcall 'dynamic-state? #f (a)) (unary emit-dynamic-state? a))
- (($ $primcall 'frame? #f (a)) (unary emit-frame? a))
- (($ $primcall 'keyword? #f (a)) (unary emit-keyword? a))
- (($ $primcall 'atomic-box? #f (a)) (unary emit-atomic-box? a))
- (($ $primcall 'syntax? #f (a)) (unary emit-syntax? a))
- (($ $primcall 'program? #f (a)) (unary emit-program? a))
- (($ $primcall 'vm-continuation? #f (a)) (unary emit-vm-continuation?
a))
- (($ $primcall 'bytevector? #f (a)) (unary emit-bytevector? a))
- (($ $primcall 'weak-set? #f (a)) (unary emit-weak-set? a))
- (($ $primcall 'weak-table? #f (a)) (unary emit-weak-table? a))
- (($ $primcall 'array? #f (a)) (unary emit-array? a))
- (($ $primcall 'bitvector? #f (a)) (unary emit-bitvector? a))
- (($ $primcall 'smob? #f (a)) (unary emit-smob? a))
- (($ $primcall 'port? #f (a)) (unary emit-port? a))
- (($ $primcall 'bignum? #f (a)) (unary emit-bignum? a))
- (($ $primcall 'flonum? #f (a)) (unary emit-flonum? a))
- (($ $primcall 'compnum? #f (a)) (unary emit-compnum? a))
- (($ $primcall 'fracnum? #f (a)) (unary emit-fracnum? a))
+ (#('pair? #f (a)) (unary emit-pair? a))
+ (#('struct? #f (a)) (unary emit-struct? a))
+ (#('symbol? #f (a)) (unary emit-symbol? a))
+ (#('variable? #f (a)) (unary emit-variable? a))
+ (#('vector? #f (a)) (unary emit-vector? a))
+ (#('string? #f (a)) (unary emit-string? a))
+ (#('heap-number? #f (a)) (unary emit-heap-number? a))
+ (#('hash-table? #f (a)) (unary emit-hash-table? a))
+ (#('pointer? #f (a)) (unary emit-pointer? a))
+ (#('fluid? #f (a)) (unary emit-fluid? a))
+ (#('stringbuf? #f (a)) (unary emit-stringbuf? a))
+ (#('dynamic-state? #f (a)) (unary emit-dynamic-state? a))
+ (#('frame? #f (a)) (unary emit-frame? a))
+ (#('keyword? #f (a)) (unary emit-keyword? a))
+ (#('atomic-box? #f (a)) (unary emit-atomic-box? a))
+ (#('syntax? #f (a)) (unary emit-syntax? a))
+ (#('program? #f (a)) (unary emit-program? a))
+ (#('vm-continuation? #f (a)) (unary emit-vm-continuation? a))
+ (#('bytevector? #f (a)) (unary emit-bytevector? a))
+ (#('weak-set? #f (a)) (unary emit-weak-set? a))
+ (#('weak-table? #f (a)) (unary emit-weak-table? a))
+ (#('array? #f (a)) (unary emit-array? a))
+ (#('bitvector? #f (a)) (unary emit-bitvector? a))
+ (#('smob? #f (a)) (unary emit-smob? a))
+ (#('port? #f (a)) (unary emit-port? a))
+ (#('bignum? #f (a)) (unary emit-bignum? a))
+ (#('flonum? #f (a)) (unary emit-flonum? a))
+ (#('compnum? #f (a)) (unary emit-compnum? a))
+ (#('fracnum? #f (a)) (unary emit-fracnum? a))
;; Binary predicates.
- (($ $primcall 'eq? #f (a b)) (binary-test emit-eq? a b))
- (($ $primcall 'heap-numbers-equal? #f (a b))
+ (#('eq? #f (a b)) (binary-test emit-eq? a b))
+ (#('heap-numbers-equal? #f (a b))
(binary-test emit-heap-numbers-equal? a b))
- (($ $primcall '< #f (a b)) (binary-< emit-<? a b))
- (($ $primcall '<= #f (a b)) (binary-<= emit-<? a b))
- (($ $primcall '= #f (a b)) (binary-test emit-=? a b))
- (($ $primcall 'u64-< #f (a b)) (binary-< emit-u64<? a b))
- (($ $primcall 'u64-imm-< b (a)) (binary-</imm emit-u64-imm<? a b))
- (($ $primcall 'imm-u64-< b (a)) (binary-</imm emit-imm-u64<? a b))
- (($ $primcall 'u64-= #f (a b)) (binary-test emit-u64=? a b))
- (($ $primcall 'u64-imm-= b (a)) (binary-test/imm emit-s64-imm=? a b))
- (($ $primcall 's64-= #f (a b)) (binary-test emit-u64=? a b))
- (($ $primcall 's64-imm-= b (a)) (binary-test/imm emit-s64-imm=? a b))
- (($ $primcall 's64-< #f (a b)) (binary-< emit-s64<? a b))
- (($ $primcall 's64-imm-< b (a)) (binary-</imm emit-s64-imm<? a b))
- (($ $primcall 'imm-s64-< b (a)) (binary-</imm emit-imm-s64<? a b))
- (($ $primcall 'f64-< #f (a b)) (binary-< emit-f64<? a b))
- (($ $primcall 'f64-<= #f (a b)) (binary-<= emit-f64<? a b))
- (($ $primcall 'f64-= #f (a b)) (binary-test emit-f64=? a b))))
+ (#('< #f (a b)) (binary-< emit-<? a b))
+ (#('<= #f (a b)) (binary-<= emit-<? a b))
+ (#('= #f (a b)) (binary-test emit-=? a b))
+ (#('u64-< #f (a b)) (binary-< emit-u64<? a b))
+ (#('u64-imm-< b (a)) (binary-</imm emit-u64-imm<? a b))
+ (#('imm-u64-< b (a)) (binary-</imm emit-imm-u64<? a b))
+ (#('u64-= #f (a b)) (binary-test emit-u64=? a b))
+ (#('u64-imm-= b (a)) (binary-test/imm emit-s64-imm=? a b))
+ (#('s64-= #f (a b)) (binary-test emit-u64=? a b))
+ (#('s64-imm-= b (a)) (binary-test/imm emit-s64-imm=? a b))
+ (#('s64-< #f (a b)) (binary-< emit-s64<? a b))
+ (#('s64-imm-< b (a)) (binary-</imm emit-s64-imm<? a b))
+ (#('imm-s64-< b (a)) (binary-</imm emit-imm-s64<? a b))
+ (#('f64-< #f (a b)) (binary-< emit-f64<? a b))
+ (#('f64-<= #f (a b)) (binary-<= emit-f64<? a b))
+ (#('f64-= #f (a b)) (binary-test emit-f64=? a b))))
(define (compile-trunc label k exp nreq rest-var)
(define (do-call proc args emit-call)
@@ -599,13 +599,8 @@
(compile-value label exp dst)))
(maybe-emit-jump))
(($ $kargs () ())
- (match exp
- (($ $branch kt exp)
- (compile-test label exp (forward-label kt) forwarded-k
- (skip-elided-conts (1+ label))))
- (_
- (compile-effect label exp k)
- (maybe-emit-jump))))
+ (compile-effect label exp k)
+ (maybe-emit-jump))
(($ $kargs names syms)
(compile-values label exp syms)
(maybe-emit-jump))
@@ -620,6 +615,20 @@
(unless fallthrough?
(emit-j asm kargs)))))))
+ (define (compile-term label term)
+ (match term
+ (($ $continue k src exp)
+ (when src
+ (emit-source asm src))
+ (unless (elide-cont? label)
+ (compile-expression label k exp)))
+ (($ $branch kf kt src op param args)
+ (when src
+ (emit-source asm src))
+ (compile-test label (skip-elided-conts (1+ label))
+ (forward-label kf) (forward-label kt)
+ op param args))))
+
(define (compile-cont label cont)
(match cont
(($ $kfun src meta self tail clause)
@@ -646,7 +655,7 @@
(let ((body (forward-label body)))
(unless (= body (skip-elided-conts (1+ label)))
(emit-j asm body)))))
- (($ $kargs names vars ($ $continue k src exp))
+ (($ $kargs names vars term)
(emit-label asm label)
(for-each (lambda (name var)
(let ((slot (maybe-slot var)))
@@ -654,10 +663,7 @@
(let ((repr (lookup-representation var allocation)))
(emit-definition asm name slot repr)))))
names vars)
- (when src
- (emit-source asm src))
- (unless (elide-cont? label)
- (compile-expression label k exp)))
+ (compile-term label term))
(($ $kreceive arity kargs)
(emit-label asm label))
(($ $ktail)
diff --git a/module/language/cps/contification.scm
b/module/language/cps/contification.scm
index 1b1fc62..ca1a292 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.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
@@ -60,8 +60,12 @@ predecessor."
(($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
(($ $ktail) (ref0))
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
+ (($ $kargs names syms ($ $branch kf kt))
+ (ref2 kf kt))
(($ $kargs names syms ($ $continue k src exp))
- (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f))))))
+ (match exp
+ (($ $prompt escape-only? tag handler) (ref2 k handler))
+ (_ (ref1 k))))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intmap-fold add-ref conts single
multiple)))
(intset-subtract (persistent-intset single)
@@ -187,12 +191,12 @@ $call, and are always called with a compatible arity."
(restrict-arity functions proc (length args))))
(($ $callk k proc args)
(exclude-vars functions (cons proc args)))
- (($ $branch kt ($ $primcall name param args))
- (exclude-vars functions args))
(($ $primcall name param args)
(exclude-vars functions args))
(($ $prompt escape? tag handler)
(exclude-var functions tag))))
+ (($ $kargs _ _ ($ $branch kf kt src op param args))
+ (exclude-vars functions args))
(_ functions)))
(intmap-fold visit-cont conts functions)))
@@ -451,6 +455,12 @@ function set."
(((names vars funs) ...)
(continue cps k src (build-exp ($rec names vars funs))))))
(_ (continue cps k src exp))))
+ (define (visit-term cps term)
+ (match term
+ (($ $continue k src exp)
+ (visit-exp cps k src exp))
+ (($ $branch)
+ (with-cps cps term))))
;; Renumbering is not strictly necessary but some passes may not be
;; equipped to deal with stale $kfun nodes whose bodies have been
@@ -460,13 +470,13 @@ function set."
(intmap-fold
(lambda (label cont out)
(match cont
- (($ $kargs names vars ($ $continue k src exp))
+ (($ $kargs names vars term)
;; Remove bindings for functions that have been contified.
(match (filter (match-lambda ((name var) (not (call-subst var))))
(map list names vars))
(((names vars) ...)
(with-cps out
- (let$ term (visit-exp k src exp))
+ (let$ term (visit-term term))
(setk label ($kargs names vars ,term))))))
(_ out)))
conts
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 3696745..8f4ae6d 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.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
@@ -114,11 +114,13 @@ false. It could be that both true and false proofs are
available."
(values (append changed0 changed1) boolv)))
(match (intmap-ref conts label)
- (($ $kargs names vars ($ $continue k src exp))
- (match exp
- (($ $branch kt) (propagate-branch k kt))
- (($ $prompt escape? tag handler) (propagate2 k handler))
- (_ (propagate1 k))))
+ (($ $kargs names vars term)
+ (match term
+ (($ $continue k src exp)
+ (match exp
+ (($ $prompt escape? tag handler) (propagate2 k handler))
+ (_ (propagate1 k))))
+ (($ $branch kf kt) (propagate-branch kf kt))))
(($ $kreceive arity k)
(propagate1 k))
(($ $kfun src meta self tail clause)
@@ -160,10 +162,14 @@ false. It could be that both true and false proofs are
available."
(($ $kargs names vars) vars)))
(($ $ktail)
'())
- (($ $kargs names vars ($ $continue k))
- (match (intmap-ref conts k)
- (($ $kargs names vars) vars)
- (_ #f)))))
+ (($ $kargs names vars term)
+ (match term
+ (($ $continue k)
+ (match (intmap-ref conts k)
+ (($ $kargs names vars) vars)
+ (_ #f)))
+ (($ $branch)
+ '())))))
(compute-function-body conts kfun)))
(define (compute-singly-referenced succs)
@@ -199,23 +205,25 @@ false. It could be that both true and false proofs are
available."
(() '())
((var . vars) (cons (subst-var var-substs var) (lp vars))))))
- (define (compute-exp-key var-substs exp)
- (match exp
- (($ $const val) (cons 'const val))
- (($ $prim name) (cons 'prim name))
- (($ $fun body) #f)
- (($ $rec names syms funs) #f)
- (($ $closure label nfree) #f)
- (($ $call proc args) #f)
- (($ $callk k proc args) #f)
- (($ $primcall name param args)
- (cons* name param (subst-vars var-substs args)))
- (($ $branch _ ($ $primcall name param args))
- (cons* name param (subst-vars var-substs args)))
- (($ $values args) #f)
- (($ $prompt escape? tag handler) #f)))
+ (define (compute-term-key var-substs term)
+ (match term
+ (($ $continue k src exp)
+ (match exp
+ (($ $const val) (cons 'const val))
+ (($ $prim name) (cons 'prim name))
+ (($ $fun body) #f)
+ (($ $rec names syms funs) #f)
+ (($ $closure label nfree) #f)
+ (($ $call proc args) #f)
+ (($ $callk k proc args) #f)
+ (($ $primcall name param args)
+ (cons* name param (subst-vars var-substs args)))
+ (($ $values args) #f)
+ (($ $prompt escape? tag handler) #f)))
+ (($ $branch kf kt src op param args)
+ (cons* op param (subst-vars var-substs args)))))
- (define (add-auxiliary-definitions! label var-substs exp-key)
+ (define (add-auxiliary-definitions! label var-substs term-key)
(let ((defs (and=> (intmap-ref defs label)
(lambda (defs) (subst-vars var-substs defs)))))
(define (add-def! aux-key var)
@@ -229,7 +237,7 @@ false. It could be that both true and false proofs are
available."
((add-definitions
((def <- op arg ...) (aux <- op* arg* ...) ...)
. clauses)
- (match exp-key
+ (match term-key
(('op arg ...)
(match defs
((def) (add-def! (list 'op* arg* ...) aux) ...)))
@@ -237,7 +245,7 @@ false. It could be that both true and false proofs are
available."
((add-definitions
((op arg ...) (aux <- op* arg* ...) ...)
. clauses)
- (match exp-key
+ (match term-key
(('op arg ...)
(add-def! (list 'op* arg* ...) aux) ...)
(_ (add-definitions . clauses))))))
@@ -282,12 +290,18 @@ false. It could be that both true and false proofs are
available."
((u <- s64->u64 #f s) (s <- u64->s64 #f u)))))
(define (visit-label label equiv-labels var-substs)
+ (define (term-defs term)
+ (match term
+ (($ $continue k)
+ (and (intset-ref singly-referenced k)
+ (intmap-ref defs label)))
+ (($ $branch) '())))
(match (intmap-ref conts label)
- (($ $kargs names vars ($ $continue k src exp))
- (match (compute-exp-key var-substs exp)
+ (($ $kargs names vars term)
+ (match (compute-term-key var-substs term)
(#f (values equiv-labels var-substs))
- (exp-key
- (let* ((equiv (hash-ref equiv-set exp-key '()))
+ (term-key
+ (let* ((equiv (hash-ref equiv-set term-key '()))
(fx (intmap-ref effects label))
(avail (intmap-ref avail label)))
(define (finish equiv-labels var-substs)
@@ -296,7 +310,7 @@ false. It could be that both true and false proofs are
available."
;; define those. Do so after finding equivalent
;; expressions, so that we can take advantage of
;; subst'd output vars.
- (add-auxiliary-definitions! label var-substs exp-key)
+ (add-auxiliary-definitions! label var-substs term-key)
(values equiv-labels var-substs))
(let lp ((candidates equiv))
(match candidates
@@ -310,10 +324,9 @@ false. It could be that both true and false proofs are
available."
;; allocation case).
(when (and (not (causes-effect? fx &allocation))
(not (effect-clobbers? fx (&read-object
&fluid))))
- (let ((defs (and (intset-ref singly-referenced k)
- (intmap-ref defs label))))
+ (let ((defs (term-defs term)))
(when defs
- (hash-set! equiv-set exp-key
+ (hash-set! equiv-set term-key
(acons label defs equiv)))))
(finish equiv-labels var-substs))
(((and head (candidate . vars)) . candidates)
@@ -327,8 +340,7 @@ false. It could be that both true and false proofs are
available."
;; we provide the definitions for the successor, mark
;; the vars for substitution.
(finish (intmap-add equiv-labels label head)
- (let ((defs (and (intset-ref singly-referenced
k)
- (intmap-ref defs label))))
+ (let ((defs (term-defs term)))
(if defs
(fold (lambda (def var var-substs)
(intmap-add var-substs def var))
@@ -364,44 +376,41 @@ false. It could be that both true and false proofs are
available."
($callk k (subst-var proc) ,(map subst-var args)))
(($ $primcall name param args)
($primcall name param ,(map subst-var args)))
- (($ $branch k exp)
- ($branch k ,(visit-exp exp)))
(($ $values args)
($values ,(map subst-var args)))
(($ $prompt escape? tag handler)
($prompt escape? (subst-var tag) handler))))
+ (define (visit-term label term)
+ (match term
+ (($ $branch kf kt src op param args)
+ (match (intmap-ref equiv-labels label (lambda (_) #f))
+ ((equiv) ; A branch defines no values.
+ (let* ((bool (intmap-ref truthy-labels label))
+ (t (intset-ref bool (true-idx equiv)))
+ (f (intset-ref bool (false-idx equiv))))
+ (if (eqv? t f)
+ (build-term
+ ($branch kf kt src op param ,(map subst-var args)))
+ (build-term
+ ($continue (if t kt kf) src ($values ()))))))
+ (#f
+ (build-term
+ ($branch kf kt src op param ,(map subst-var args))))))
+ (($ $continue k src exp)
+ (match (intmap-ref equiv-labels label (lambda (_) #f))
+ ((equiv . vars)
+ (build-term ($continue k src ($values vars))))
+ (#f
+ (build-term
+ ($continue k src ,(visit-exp exp))))))))
+
(intmap-map
(lambda (label cont)
- (match cont
- (($ $kargs names vars ($ $continue k src exp))
- (build-cont
- ($kargs names vars
- ,(match (intmap-ref equiv-labels label (lambda (_) #f))
- ((equiv . vars)
- (match exp
- (($ $branch kt exp)
- (let* ((bool (intmap-ref truthy-labels label))
- (t (intset-ref bool (true-idx equiv)))
- (f (intset-ref bool (false-idx equiv))))
- (if (eqv? t f)
- (build-term
- ($continue k src
- ($branch kt ,(visit-exp exp))))
- (build-term
- ($continue (if t kt k) src ($values ()))))))
- (_
- ;; For better or for worse, we only replace primcalls
- ;; if they have an associated VM op, which allows
- ;; them to continue to $kargs and thus we know their
- ;; defs and can use a $values expression instead of a
- ;; values primcall.
- (build-term
- ($continue k src ($values vars))))))
- (#f
- (build-term
- ($continue k src ,(visit-exp exp))))))))
- (_ cont)))
+ (rewrite-cont cont
+ (($ $kargs names vars term)
+ ($kargs names vars ,(visit-term label term)))
+ (_ ,cont)))
conts))
(define (eliminate-common-subexpressions conts)
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index d896b36..829ab36 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.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
@@ -80,6 +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))
(($ $kreceive arity kargs)
(values known (intset-add! unknown kargs)))
(($ $kfun src meta self tail clause)
@@ -151,8 +155,6 @@ sites."
(adjoin-vars args (adjoin-var proc live-vars))))
(($ $primcall name param args)
(values live-labels (adjoin-vars args live-vars)))
- (($ $branch k ($ $primcall name param args))
- (values live-labels (adjoin-vars args live-vars)))
(($ $values args)
(values live-labels
(match (cont-defs k)
@@ -164,17 +166,6 @@ sites."
live-vars args defs)))))))
(define (visit-exp label k exp live-labels live-vars)
- (define (next-live-term k)
- ;; FIXME: For a chain of dead branches, this is quadratic.
- (let lp ((seen empty-intset) (k k))
- (cond
- ((intset-ref live-labels k) k)
- ((intset-ref seen k) k)
- (else
- (match (intmap-ref conts k)
- (($ $kargs _ _ ($ $continue k*))
- (lp (intset-add seen k) k*))
- (_ k))))))
(cond
((intset-ref live-labels label)
;; Expression live already.
@@ -192,12 +183,6 @@ sites."
;; Does it cause a type check, but we weren't able to prove
;; that the types check?
(causes-effect? fx &type-check)
- ;; We only remove branches if both continuations are the
- ;; same.
- (match exp
- (($ $branch kt)
- (not (eqv? (next-live-term k) (next-live-term kt))))
- (_ #f))
;; We might have a setter. If the object being assigned to
;; is live or was not created by us, then this expression is
;; live. Otherwise the value is still dead.
@@ -219,6 +204,32 @@ sites."
;; Still dead.
(values live-labels live-vars))))
+ (define (visit-branch label kf kt args live-labels live-vars)
+ (define (next-live-term k)
+ ;; FIXME: For a chain of dead branches, this is quadratic.
+ (let lp ((seen empty-intset) (k k))
+ (cond
+ ((intset-ref live-labels k) k)
+ ((intset-ref seen k) k)
+ (else
+ (match (intmap-ref conts k)
+ (($ $kargs _ _ ($ $continue k*))
+ (lp (intset-add seen k) k*))
+ (_ k))))))
+ (cond
+ ((intset-ref live-labels label)
+ ;; Branch live already.
+ (values live-labels (adjoin-vars args live-vars)))
+ ((or (causes-effect? (intmap-ref effects label) &type-check)
+ (not (eqv? (next-live-term kf) (next-live-term kt))))
+ ;; The branch is live if its continuations are not the same, or
+ ;; if the branch itself causes type checks.
+ (values (intset-add live-labels label)
+ (adjoin-vars args live-vars)))
+ (else
+ ;; Still dead.
+ (values live-labels live-vars))))
+
(define (visit-fun label live-labels live-vars)
;; Visit uses before definitions.
(postorder-fold-local-conts2
@@ -226,6 +237,8 @@ sites."
(match cont
(($ $kargs _ _ ($ $continue k src exp))
(visit-exp label k exp live-labels live-vars))
+ (($ $kargs _ _ ($ $branch kf kt src op param args))
+ (visit-branch label kf kt args live-labels live-vars))
(($ $kreceive arity kargs)
(values live-labels live-vars))
(($ $kclause arity kargs kalt)
@@ -327,7 +340,13 @@ sites."
(values cps term)))))
(values cps
(build-term
- ($continue k src ($values ()))))))))
+ ($continue k src ($values ()))))))
+ (($ $branch kf kt src op param args)
+ (if (label-live? label)
+ (values cps term)
+ ;; Dead branches continue to the same continuation
+ ;; (eventually).
+ (values cps (build-term ($continue kf src ($values ()))))))))
(define (visit-cont label cont cps)
(match cont
(($ $kargs names vars term)
diff --git a/module/language/cps/devirtualize-integers.scm
b/module/language/cps/devirtualize-integers.scm
index 1cedaea..9ebe6fc 100644
--- a/module/language/cps/devirtualize-integers.scm
+++ b/module/language/cps/devirtualize-integers.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2017 Free Software Foundation, Inc.
+;; Copyright (C) 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
@@ -59,22 +59,24 @@
(intmap-fold
(lambda (label cont use-counts)
(match cont
- (($ $kargs names vars ($ $continue k src exp))
- (match exp
- ((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $rec))
- use-counts)
- (($ $values args)
- (add-uses use-counts args))
- (($ $call proc args)
- (add-uses (add-use use-counts proc) args))
- (($ $callk kfun proc args)
- (add-uses (add-use use-counts proc) args))
- (($ $branch kt ($ $primcall name param args))
- (add-uses use-counts args))
- (($ $primcall name param args)
- (add-uses use-counts args))
- (($ $prompt escape? tag handler)
- (add-use use-counts tag))))
+ (($ $kargs names vars term)
+ (match term
+ (($ $continue k src exp)
+ (match exp
+ ((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $rec))
+ use-counts)
+ (($ $values args)
+ (add-uses use-counts args))
+ (($ $call proc args)
+ (add-uses (add-use use-counts proc) args))
+ (($ $callk kfun proc args)
+ (add-uses (add-use use-counts proc) args))
+ (($ $primcall name param args)
+ (add-uses use-counts args))
+ (($ $prompt escape? tag handler)
+ (add-use use-counts tag))))
+ (($ $branch kf kt src op param args)
+ (add-uses use-counts args))))
(_ use-counts)))
cps
(transient-intmap))))
@@ -124,7 +126,7 @@ the trace should be referenced outside of it."
;; graph to get to $kreceive etc, so we can stop with these two
;; continuation kinds.
(($ $ktail) (fail))
- (($ $kargs names vars ($ $continue k src exp))
+ (($ $kargs names vars term)
(let* ((vars-of-interest
(if defs-of-interest?
(fold1 (lambda (var set) (intset-add set var))
@@ -134,7 +136,8 @@ the trace should be referenced outside of it."
(fresh-vars (fold (lambda (var fresh-vars)
(intmap-add fresh-vars var (fresh-var)))
fresh-vars vars))
- (vars (map (lambda (var) (intmap-ref fresh-vars var)) vars)))
+ (peeled-vars (map (lambda (var) (intmap-ref fresh-vars var))
+ vars)))
(define (rename-uses args)
(map (lambda (arg) (intmap-ref fresh-vars arg (lambda (arg) arg)))
args))
@@ -142,10 +145,10 @@ the trace should be referenced outside of it."
(or-map (lambda (arg) (intset-ref vars-of-interest arg))
args))
(define (continue k live-vars defs-of-interest? can-terminate-trace?
- exp)
+ make-term)
(define (stitch cps k)
(with-cps cps
- (letk label* ($kargs names vars ($continue k src ,exp)))
+ (letk label* ($kargs names peeled-vars ,(make-term k)))
label*))
(define (terminate)
(stitch cps k))
@@ -158,73 +161,71 @@ the trace should be referenced outside of it."
((and can-terminate-trace? (eq? live-vars empty-intmap))
(terminate))
(else (fail))))))))
- (match exp
- (($ $const)
- ;; fine.
- (continue k live-vars #f #f exp))
- (($ $values args)
- (let ((live-vars (subtract-uses live-vars args)))
- (continue k live-vars
- (any-use-of-interest? args) #f
- (build-exp ($values ,(rename-uses args))))))
- (($ $primcall name param args)
- ;; exp is effect-free or var of interest in args
- (let* ((fx (expression-effects exp))
- (uses-of-interest? (any-use-of-interest? args))
- (live-vars (subtract-uses live-vars args)))
- ;; If the primcall uses a value of interest,
- ;; consider it for peeling even if it would cause a
- ;; type check; perhaps the peeling causes the type
- ;; check to go away.
- (if (or (eqv? fx &no-effects)
- (and uses-of-interest? (eqv? fx &type-check)))
- (continue k (subtract-uses live-vars args)
- ;; Primcalls that use values of interest
- ;; define values of interest.
- uses-of-interest? #t
- (build-exp
- ($primcall name param ,(rename-uses args))))
- (fail))))
- (($ $branch kt ($ $primcall name param args))
+ (match term
+ (($ $branch kf kt src op param args)
;; kt or k is kf; var of interest is in args
(let* ((live-vars (subtract-uses live-vars args))
(uses-of-interest? (any-use-of-interest? args))
(defs-of-interest? #f) ;; Branches don't define values.
(can-terminate-trace? uses-of-interest?)
- (exp (build-exp
- ($primcall name param ,(rename-uses args)))))
+ (peeled-args (rename-uses args)))
(cond
((not (any-use-of-interest? args))
(fail))
((bailout? kt)
- (continue k live-vars defs-of-interest? can-terminate-trace?
- (build-exp ($branch kt ,exp))))
- ((bailout? k)
- (let ()
- (define (stitch cps kt)
- (with-cps cps
- (letk label*
- ($kargs names vars
- ($continue k src ($branch kt ,exp))))
- label*))
- (define (terminate)
- (stitch cps kt))
- (with-cps cps
- (let$ kt* (peel-cont kt live-vars fresh-vars
- vars-of-interest defs-of-interest?))
- ($ ((lambda (cps)
- (cond
- (kt* (stitch cps kt*))
- ((and can-terminate-trace? (eq? live-vars
empty-intmap))
- (terminate))
- (else (fail)))))))))
+ (continue kf live-vars defs-of-interest? can-terminate-trace?
+ (lambda (kf)
+ (build-term
+ ($branch kf kt src op param peeled-args)))))
+ ((bailout? kf)
+ (continue kt live-vars defs-of-interest? can-terminate-trace?
+ (lambda (kt)
+ (build-term
+ ($branch kf kt src op param peeled-args)))))
(else
(with-cps cps
(letk label*
- ($kargs names vars
- ($continue k src ($branch kt ,exp))))
+ ($kargs names peeled-vars
+ ($branch kf kt src op param peeled-args)))
label*)))))
- (_ (fail))))))))
+ (($ $continue k src exp)
+ (match exp
+ (($ $const)
+ ;; fine.
+ (continue k live-vars #f #f
+ (lambda (k)
+ (build-term ($continue k src ,exp)))))
+ (($ $values args)
+ (let ((uses-of-interest? (any-use-of-interest? args))
+ (live-vars (subtract-uses live-vars args))
+ (peeled-args (rename-uses args)))
+ (continue k live-vars
+ uses-of-interest? #f
+ (lambda (k)
+ (build-term
+ ($continue k src ($values peeled-args)))))))
+ (($ $primcall name param args)
+ ;; exp is effect-free or var of interest in args
+ (let* ((fx (expression-effects exp))
+ (uses-of-interest? (any-use-of-interest? args))
+ (live-vars (subtract-uses live-vars args))
+ (peeled-args (rename-uses args)))
+ ;; If the primcall uses a value of interest,
+ ;; consider it for peeling even if it would cause a
+ ;; type check; perhaps the peeling causes the type
+ ;; check to go away.
+ (if (or (eqv? fx &no-effects)
+ (and uses-of-interest? (eqv? fx &type-check)))
+ (continue k live-vars
+ ;; Primcalls that use values of interest
+ ;; define values of interest.
+ uses-of-interest? #t
+ (lambda (k)
+ (build-term
+ ($continue k src
+ ($primcall name param ,peeled-args)))))
+ (fail))))
+ (_ (fail))))))))))
(define (peel-traces-in-function cps body use-counts)
(intset-fold
@@ -232,9 +233,7 @@ the trace should be referenced outside of it."
(match (intmap-ref cps label)
;; Traces start with a fixnum? predicate. We could expand this
;; in the future if we wanted to.
- (($ $kargs names vars
- ($ $continue kf src
- ($ $branch kt ($ $primcall 'fixnum? #f (x)))))
+ (($ $kargs names vars ($ $branch kf kt src 'fixnum? #f (x)))
(with-cps cps
(let$ kt (peel-trace kt x kf use-counts))
($ ((lambda (cps)
@@ -242,8 +241,7 @@ the trace should be referenced outside of it."
(with-cps cps
(setk label
($kargs names vars
- ($continue kf src
- ($branch kt ($primcall 'fixnum? #f (x)))))))
+ ($branch kf kt src 'fixnum? #f (x)))))
cps))))))
(_ cps)))
body
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index b49ef15..854bd11 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -1,6 +1,6 @@
;;; Effects analysis on CPS
-;; Copyright (C) 2011-2015, 2017 Free Software Foundation, Inc.
+;; Copyright (C) 2011-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
@@ -603,8 +603,6 @@ the LABELS that are clobbered by the effects of LABEL."
&all-effects)
((or ($ $call) ($ $callk))
&all-effects)
- (($ $branch k exp)
- (expression-effects exp))
(($ $primcall name param args)
(primitive-effects param name args))))
@@ -614,6 +612,8 @@ the LABELS that are clobbered by the effects of LABEL."
(match cont
(($ $kargs names syms ($ $continue k src exp))
(expression-effects exp))
+ (($ $kargs names syms ($ $branch kf kt src op param args))
+ (primitive-effects param op args))
(($ $kreceive arity kargs)
(match arity
(($ $arity _ () #f () #f) &type-check)
diff --git a/module/language/cps/handle-interrupts.scm
b/module/language/cps/handle-interrupts.scm
index 758637c..614b7a4 100644
--- a/module/language/cps/handle-interrupts.scm
+++ b/module/language/cps/handle-interrupts.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2016, 2017 Free Software Foundation, Inc.
+;; Copyright (C) 2016, 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
@@ -34,12 +34,15 @@
#:export (add-handle-interrupts))
(define (compute-safepoints cps)
+ (define (maybe-add-safepoint label k safepoints)
+ "Add K to safepoints if it is a target of a backward branch."
+ (if (<= k label)
+ (intset-add! safepoints k)
+ safepoints))
(define (visit-cont label cont safepoints)
(match cont
(($ $kargs names vars ($ $continue k src exp))
- (let ((safepoints (if (<= k label)
- (intset-add! safepoints k)
- safepoints)))
+ (let ((safepoints (maybe-add-safepoint label k safepoints)))
(if (match exp
(($ $call) #t)
(($ $callk) #t)
@@ -50,18 +53,21 @@
(_ #f))
(intset-add! safepoints label)
safepoints)))
+ (($ $kargs names vars ($ $branch kf kt))
+ (maybe-add-safepoint label kf
+ (maybe-add-safepoint label kt safepoints)))
(_ safepoints)))
(persistent-intset (intmap-fold visit-cont cps empty-intset)))
(define (add-handle-interrupts cps)
(define (add-safepoint label cps)
(match (intmap-ref cps label)
- (($ $kargs names vars ($ $continue k src exp))
+ (($ $kargs names vars term)
(with-cps cps
- (letk k* ($kargs () () ($continue k src ,exp)))
+ (letk k ($kargs () () ,term))
(setk label
($kargs names vars
- ($continue k* src
+ ($continue k #f
($primcall 'handle-interrupts #f ()))))))))
(let* ((cps (renumber cps))
(safepoints (compute-safepoints cps)))
diff --git a/module/language/cps/licm.scm b/module/language/cps/licm.scm
index 3e612a2..b016b3b 100644
--- a/module/language/cps/licm.scm
+++ b/module/language/cps/licm.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
@@ -69,7 +69,6 @@
(match exp
((or ($ $const) ($ $prim) ($ $closure)) #t)
(($ $prompt) #f) ;; ?
- (($ $branch) #f)
(($ $primcall name param args)
(and-map (lambda (arg) (not (intset-ref loop-vars arg)))
args))
@@ -127,93 +126,98 @@
pre-header-label pre-header-cont)
pre-header-label)))
(match cont
- (($ $kargs names vars ($ $continue k src exp))
- ;; If k is a loop exit, it will be nullary.
+ (($ $kargs names vars term)
(let-values (((names vars) (filter-loop-vars names vars)))
- (match (intmap-ref cps k)
- (($ $kargs def-names def-vars)
- (cond
- ((not (loop-invariant? label exp loop-vars loop-effects
- always-reached?))
- (let* ((loop-vars (adjoin-loop-vars loop-vars def-vars))
- (loop-vars (match exp
- (($ $prompt escape? tag handler)
- (match (intmap-ref cps handler)
- (($ $kreceive arity kargs)
- (match (intmap-ref cps kargs)
- (($ $kargs names vars)
- (adjoin-loop-vars loop-vars vars))))))
- (_ loop-vars)))
- (cont (build-cont
- ($kargs names vars
- ($continue k src ,exp))))
- (always-reached?
- (and always-reached?
- (match exp
- (($ $branch) #f)
- (_ (not (causes-effect? (intmap-ref loop-effects
label)
- &type-check)))))))
- (values cps cont loop-vars loop-effects
- pre-header-label always-reached?)))
- ((trivial-intset (intmap-ref preds k))
- (let-values
- (((cps pre-header-label)
- (hoist-exp src exp def-names def-vars pre-header-label))
- ((cont) (build-cont
- ($kargs names vars
- ($continue k src ($values ()))))))
- (values cps cont loop-vars (intmap-remove loop-effects label)
- pre-header-label always-reached?)))
- (else
- (let*-values
- (((def-names def-vars)
- (match (intmap-ref cps k)
- (($ $kargs names vars) (values names vars))))
- ((loop-vars) (adjoin-loop-vars loop-vars def-vars))
- ((fresh-vars) (map (lambda (_) (fresh-var)) def-vars))
- ((cps pre-header-label)
- (hoist-exp src exp def-names fresh-vars pre-header-label))
- ((cont) (build-cont
- ($kargs names vars
- ($continue k src ($values fresh-vars))))))
- (values cps cont loop-vars (intmap-remove loop-effects label)
- pre-header-label always-reached?)))))
- (($ $kreceive ($ $arity req () rest) kargs)
- (match (intmap-ref cps kargs)
+ (match term
+ (($ $continue k src exp)
+ ;; If k is a loop exit, it will be nullary.
+ (match (intmap-ref cps k)
(($ $kargs def-names def-vars)
(cond
((not (loop-invariant? label exp loop-vars loop-effects
always-reached?))
(let* ((loop-vars (adjoin-loop-vars loop-vars def-vars))
+ (loop-vars (match exp
+ (($ $prompt escape? tag handler)
+ (match (intmap-ref cps handler)
+ (($ $kreceive arity kargs)
+ (match (intmap-ref cps kargs)
+ (($ $kargs names vars)
+ (adjoin-loop-vars loop-vars
vars))))))
+ (_ loop-vars)))
(cont (build-cont
($kargs names vars
- ($continue k src ,exp)))))
- (values cps cont loop-vars loop-effects pre-header-label #f)))
+ ($continue k src ,exp))))
+ (always-reached?
+ (and always-reached?
+ (not (causes-effect? (intmap-ref loop-effects
label)
+ &type-check)))))
+ (values cps cont loop-vars loop-effects
+ pre-header-label always-reached?)))
((trivial-intset (intmap-ref preds k))
- (let ((loop-effects
- (intmap-remove (intmap-remove loop-effects label) k)))
- (let-values
- (((cps pre-header-label)
- (hoist-call src exp req rest def-names def-vars
- pre-header-label))
- ((cont) (build-cont
- ($kargs names vars
- ($continue kargs src ($values ()))))))
- (values cps cont loop-vars loop-effects
- pre-header-label always-reached?))))
+ (let-values
+ (((cps pre-header-label)
+ (hoist-exp src exp def-names def-vars pre-header-label))
+ ((cont) (build-cont
+ ($kargs names vars
+ ($continue k src ($values ()))))))
+ (values cps cont loop-vars (intmap-remove loop-effects label)
+ pre-header-label always-reached?)))
(else
(let*-values
- (((loop-vars) (adjoin-loop-vars loop-vars def-vars))
+ (((def-names def-vars)
+ (match (intmap-ref cps k)
+ (($ $kargs names vars) (values names vars))))
+ ((loop-vars) (adjoin-loop-vars loop-vars def-vars))
((fresh-vars) (map (lambda (_) (fresh-var)) def-vars))
((cps pre-header-label)
- (hoist-call src exp req rest def-names fresh-vars
- pre-header-label))
+ (hoist-exp src exp def-names fresh-vars pre-header-label))
((cont) (build-cont
($kargs names vars
- ($continue kargs src
- ($values fresh-vars))))))
- (values cps cont loop-vars loop-effects
- pre-header-label always-reached?))))))))))
+ ($continue k src ($values fresh-vars))))))
+ (values cps cont loop-vars (intmap-remove loop-effects label)
+ pre-header-label always-reached?)))))
+ (($ $kreceive ($ $arity req () rest) kargs)
+ (match (intmap-ref cps kargs)
+ (($ $kargs def-names def-vars)
+ (cond
+ ((not (loop-invariant? label exp loop-vars loop-effects
+ always-reached?))
+ (let* ((loop-vars (adjoin-loop-vars loop-vars def-vars))
+ (cont (build-cont
+ ($kargs names vars
+ ($continue k src ,exp)))))
+ (values cps cont loop-vars loop-effects pre-header-label
#f)))
+ ((trivial-intset (intmap-ref preds k))
+ (let ((loop-effects
+ (intmap-remove (intmap-remove loop-effects label) k)))
+ (let-values
+ (((cps pre-header-label)
+ (hoist-call src exp req rest def-names def-vars
+ pre-header-label))
+ ((cont) (build-cont
+ ($kargs names vars
+ ($continue kargs src ($values ()))))))
+ (values cps cont loop-vars loop-effects
+ pre-header-label always-reached?))))
+ (else
+ (let*-values
+ (((loop-vars) (adjoin-loop-vars loop-vars def-vars))
+ ((fresh-vars) (map (lambda (_) (fresh-var)) def-vars))
+ ((cps pre-header-label)
+ (hoist-call src exp req rest def-names fresh-vars
+ pre-header-label))
+ ((cont) (build-cont
+ ($kargs names vars
+ ($continue kargs src
+ ($values fresh-vars))))))
+ (values cps cont loop-vars loop-effects
+ pre-header-label always-reached?)))))))))
+ (($ $branch)
+ (let* ((cont (build-cont ($kargs names vars ,term)))
+ (always-reached? #f))
+ (values cps cont loop-vars loop-effects
+ pre-header-label always-reached?))))))
(($ $kreceive ($ $arity req () rest) kargs)
(values cps cont loop-vars loop-effects pre-header-label
always-reached?))))
@@ -252,9 +256,9 @@
(define (rename-back-edges cont)
(define (rename label) (if (eqv? label entry) header-label label))
(rewrite-cont cont
- (($ $kargs names vars ($ $continue kf src ($ $branch kt exp)))
+ (($ $kargs names vars ($ $branch kf kt src op param args))
($kargs names vars
- ($continue (rename kf) src ($branch (rename kt) ,exp))))
+ ($branch (rename kf) (rename kt) src op param args)))
(($ $kargs names vars ($ $continue k src exp))
($kargs names vars
($continue (rename k) src ,exp)))
diff --git a/module/language/cps/peel-loops.scm
b/module/language/cps/peel-loops.scm
index c93bbc8..0f23451 100644
--- a/module/language/cps/peel-loops.scm
+++ b/module/language/cps/peel-loops.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
@@ -141,16 +141,20 @@
($call (rename-var proc) ,(map rename-var args)))
(($ $callk k proc args)
($callk k (rename-var proc) ,(map rename-var args)))
- (($ $branch kt ($ $primcall name param args))
- ($branch (rename-label kt) ($primcall name param ,(map rename-var
args))))
(($ $primcall name param args)
($primcall name param ,(map rename-var args)))
(($ $prompt escape? tag handler)
($prompt escape? (rename-var tag) (rename-label handler)))))
+ (define (rename-term term)
+ (rewrite-term term
+ (($ $continue k src exp)
+ ($continue (rename-label k) src ,(rename-exp exp)))
+ (($ $branch kf kt src op param args)
+ ($branch (rename-label kf) (rename-label kt) src
+ op param ,(map rename-var args)))))
(rewrite-cont cont
- (($ $kargs names vars ($ $continue k src exp))
- ($kargs names (map rename-var vars)
- ($continue (rename-label k) src ,(rename-exp exp))))
+ (($ $kargs names vars term)
+ ($kargs names (map rename-var vars) ,(rename-term term)))
(($ $kreceive ($ $arity req () rest) kargs)
($kreceive req rest (rename-label kargs)))))
diff --git a/module/language/cps/reify-primitives.scm
b/module/language/cps/reify-primitives.scm
index 8765ee2..afd6f71 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.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
@@ -384,8 +384,7 @@
($continue krecv src ($call proc args))))
(let$ body (resolve-prim name kproc src))
(setk label ($kargs names vars ,body))))))
- (($ $kargs names vars
- ($ $continue kf src ($ $branch kt ($ $primcall name param args))))
+ (($ $kargs names vars ($ $branch kf kt src name param args))
(let ()
(define (u11? val) (<= 0 val #x7ff))
(define (u12? val) (<= 0 val #xfff))
@@ -404,8 +403,7 @@
(letv c)
(letk kconst
($kargs ('c) (c)
- ($continue kf src
- ($branch kt ($primcall 'op* #f (out ...))))))
+ ($branch kf kt src 'op* #f (out ...))))
(setk label
($kargs names vars
($continue kconst src
diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm
index fdd1271..ba565c1 100644
--- a/module/language/cps/renumber.scm
+++ b/module/language/cps/renumber.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
@@ -85,16 +85,18 @@
(call-with-values
(lambda ()
(match (intmap-ref conts k)
- (($ $kargs names syms ($ $continue k src exp))
- (match exp
- (($ $prompt escape? tag handler)
- (visit2 k handler order visited))
- (($ $branch kt)
- (if (visit-kf-first? k kt)
- (visit2 k kt order visited)
- (visit2 kt k order visited)))
- (_
- (visit k order visited))))
+ (($ $kargs names syms term)
+ (match term
+ (($ $continue k src exp)
+ (match exp
+ (($ $prompt escape? tag handler)
+ (visit2 k handler order visited))
+ (_
+ (visit k order visited))))
+ (($ $branch kf kt)
+ (if (visit-kf-first? kf kt)
+ (visit2 kf kt order visited)
+ (visit2 kt kf order visited)))))
(($ $kreceive arity k) (visit k order visited))
(($ $kclause arity kbody kalt)
(if kalt
@@ -177,8 +179,6 @@
($call (rename-var proc) ,(map rename-var args)))
(($ $callk k proc args)
($callk (rename-label k) (rename-var proc) ,(map rename-var args)))
- (($ $branch kt exp)
- ($branch (rename-label kt) ,(rename-exp exp)))
(($ $primcall name param args)
($primcall name param ,(map rename-var args)))
(($ $prompt escape? tag handler)
@@ -200,18 +200,23 @@
out
new-k
(rewrite-cont (intmap-ref conts old-k)
- (($ $kargs names syms ($ $continue k src exp))
- ($kargs names (map rename-var syms)
- ($continue (rename-label k) src ,(rename-exp exp))))
- (($ $kreceive ($ $arity req () rest () #f) k)
- ($kreceive req rest (rename-label k)))
- (($ $ktail)
- ($ktail))
- (($ $kfun src meta self tail clause)
- ($kfun src meta (rename-var self) (rename-label tail)
- (and clause (rename-label clause))))
- (($ $kclause arity body alternate)
- ($kclause ,(rename-arity arity) (rename-label body)
- (and alternate (rename-label alternate)))))))
+ (($ $kargs names syms term)
+ ($kargs names (map rename-var syms)
+ ,(rewrite-term term
+ (($ $continue k src exp)
+ ($continue (rename-label k) src ,(rename-exp exp)))
+ (($ $branch kf kt src op param args)
+ ($branch (rename-label kf) (rename-label kt) src
+ op param ,(map rename-var args))))))
+ (($ $kreceive ($ $arity req () rest () #f) k)
+ ($kreceive req rest (rename-label k)))
+ (($ $ktail)
+ ($ktail))
+ (($ $kfun src meta self tail clause)
+ ($kfun src meta (rename-var self) (rename-label tail)
+ (and clause (rename-label clause))))
+ (($ $kclause arity body alternate)
+ ($kclause ,(rename-arity arity) (rename-label body)
+ (and alternate (rename-label alternate)))))))
label-map
empty-intmap))))
diff --git a/module/language/cps/rotate-loops.scm
b/module/language/cps/rotate-loops.scm
index 93ac0b3..dbc2f9e 100644
--- a/module/language/cps/rotate-loops.scm
+++ b/module/language/cps/rotate-loops.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
@@ -55,6 +55,7 @@
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
+ #:use-module (language cps with-cps)
#:export (rotate-loops))
(define (loop-successors scc succs)
@@ -79,7 +80,8 @@
(match (intmap-ref cps entry-label)
((and entry-cont
($ $kargs entry-names entry-vars
- ($ $continue entry-kf entry-src ($ $branch entry-kt entry-exp))))
+ ($ $branch entry-kf entry-kt entry-src
+ entry-op entry-param entry-args)))
(let* ((exit-if-true? (intset-ref body-labels entry-kf))
(loop-exits (find-exits body-labels succs))
(exit (if exit-if-true? entry-kt entry-kf))
@@ -93,49 +95,50 @@
(map (lambda (_) (fresh-var)) entry-vars))
(define (make-trampoline k src values)
(build-cont ($kargs () () ($continue k src ($values values)))))
- (define (replace-exit k trampoline)
- (if (eqv? k exit) trampoline k))
- (define (rename-exp exp vars)
- (define (rename-var var)
- (match (list-index entry-vars var)
- (#f var)
- (idx (list-ref vars idx))))
- (rewrite-exp exp
- ((or ($ $const) ($ $prim) ($ $closure)) ,exp)
- (($ $values args)
- ($values ,(map rename-var args)))
- (($ $call proc args)
- ($call (rename-var proc) ,(map rename-var args)))
- (($ $callk k proc args)
- ($callk k (rename-var proc) ,(map rename-var args)))
- (($ $branch kt ($ $primcall name param args))
- ($branch kt ($primcall name param ,(map rename-var args))))
- (($ $primcall name param args)
- ($primcall name param ,(map rename-var args)))
- (($ $prompt escape? tag handler)
- ($prompt escape? (rename-var tag) handler))))
- (define (attach-trampoline label src names vars args)
- (let* ((trampoline-out-label (fresh-label))
- (trampoline-out-cont
- (make-trampoline join-label src args))
- (trampoline-in-label (fresh-label))
- (trampoline-in-cont
- (make-trampoline new-entry-label src args))
- (kf (if exit-if-true? trampoline-in-label
trampoline-out-label))
- (kt (if exit-if-true? trampoline-out-label
trampoline-in-label))
- (cont (build-cont
- ($kargs names vars
- ($continue kf entry-src
- ($branch kt ,(rename-exp entry-exp args))))))
- (cps (intmap-replace! cps label cont))
- (cps (intmap-add! cps trampoline-in-label trampoline-in-cont)))
- (intmap-add! cps trampoline-out-label trampoline-out-cont)))
+ (define (rename-var var replacements)
+ "If VAR refers to a member of ENTRY-VARS, replace with a
+corresponding var from REPLACEMENTS; otherwise return VAR."
+ (match (list-index entry-vars var)
+ (#f var)
+ (idx (list-ref replacements idx))))
+ (define (rename-vars vars replacements)
+ (map (lambda (var) (rename-var var replacements)) vars))
+ (define (rename-term term replacements)
+ (define (rename arg) (rename-var arg replacements))
+ (define (rename* arg) (rename-vars arg replacements))
+ (rewrite-term term
+ (($ $continue k src exp)
+ ($continue k src
+ ,(rewrite-exp exp
+ ((or ($ $const) ($ $prim) ($ $closure)) ,exp)
+ (($ $values args)
+ ($values ,(rename* args)))
+ (($ $call proc args)
+ ($call (rename proc) ,(rename* args)))
+ (($ $callk k proc args)
+ ($callk k (rename proc) ,(rename* args)))
+ (($ $primcall name param args)
+ ($primcall name param ,(rename* args)))
+ (($ $prompt escape? tag handler)
+ ($prompt escape? (rename tag) handler)))))
+ (($ $branch kf kt src op param args)
+ ($branch kf kt 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))
+ (letk ktramp-in ,(make-trampoline new-entry-label src args))
+ (setk label
+ ($kargs names vars
+ ($branch (if exit-if-true? ktramp-in ktramp-out)
+ (if exit-if-true? ktramp-out ktramp-in)
+ entry-src
+ entry-op entry-param ,(rename-vars entry-args args))))))
;; Rewrite the targets of the entry branch to go to
;; trampolines. One will pass values out of the loop, and
;; one will pass values into the loop.
(let* ((pre-header-vars (make-fresh-vars))
(body-vars (make-fresh-vars))
- (cps (attach-trampoline entry-label entry-src
+ (cps (attach-trampoline cps entry-label entry-src
entry-names pre-header-vars
pre-header-vars))
(new-entry-cont (build-cont
@@ -148,44 +151,38 @@
(cond
((intset-ref back-edges label)
(match (intmap-ref cps label)
- (($ $kargs names vars ($ $continue _ src exp))
- (match (rename-exp exp body-vars)
- (($ $values args)
- (attach-trampoline label src names vars args))
- (exp
+ (($ $kargs names vars term)
+ (match (rename-term term body-vars)
+ (($ $continue _ src ($ $values args))
+ (attach-trampoline cps label src names vars args))
+ (($ $continue _ src exp)
(let* ((args (make-fresh-vars))
(bind-label (fresh-label))
(edge* (build-cont
($kargs names vars
($continue bind-label src ,exp))))
(cps (intmap-replace! cps label edge*))
- ;; attach-trampoline uses intmap-replace!.
+ ;; attach-trampoline uses setk.
(cps (intmap-add! cps bind-label #f)))
- (attach-trampoline bind-label src
+ (attach-trampoline cps bind-label src
entry-names args args)))))))
((intset-ref loop-exits label)
(match (intmap-ref cps label)
- (($ $kargs names vars
- ($ $continue kf src ($ $branch kt exp)))
- (let* ((trampoline-out-label (fresh-label))
- (trampoline-out-cont
- (make-trampoline join-label src body-vars))
- (kf (if (eqv? kf exit) trampoline-out-label kf))
- (kt (if (eqv? kt exit) trampoline-out-label kt))
- (cont (build-cont
- ($kargs names vars
- ($continue kf src
- ($branch kt ,(rename-exp exp
body-vars))))))
- (cps (intmap-replace! cps label cont)))
- (intmap-add! cps trampoline-out-label
trampoline-out-cont)))))
+ (($ $kargs names vars ($ $branch kf kt src op param args))
+ (with-cps cps
+ (letk ktramp-out ,(make-trampoline join-label src
body-vars))
+ (setk label
+ ($kargs names vars
+ ($branch (if (eqv? kf exit) ktramp-out kf)
+ (if (eqv? kt exit) ktramp-out kt)
+ src
+ op param ,(rename-vars args body-vars))))))))
(else
(match (intmap-ref cps label)
- (($ $kargs names vars ($ $continue k src exp))
- (let ((cont (build-cont
- ($kargs names vars
- ($continue k src
- ,(rename-exp exp body-vars))))))
- (intmap-replace! cps label cont)))
+ (($ $kargs names vars term)
+ (with-cps cps
+ (setk label ($kargs names vars
+ ,(rename-term term body-vars)))))
(($ $kreceive) cps)))))
(intset-remove body-labels entry-label)
cps))))))
@@ -195,10 +192,8 @@
(intset-fold (lambda (label rotate?)
(match (intmap-ref cps label)
(($ $kreceive) #f)
- (($ $kargs _ _ ($ $continue _ _ exp))
- (match exp
- (($ $branch) #f)
- (_ rotate?)))))
+ (($ $kargs _ _ ($ $branch)) #f)
+ (($ $kargs _ _ ($ $continue)) rotate?)))
edges #t))
(let* ((succs (compute-successors cps kfun))
(preds (invert-graph succs)))
diff --git a/module/language/cps/self-references.scm
b/module/language/cps/self-references.scm
index e874f0e..f1ffc4a 100644
--- a/module/language/cps/self-references.scm
+++ b/module/language/cps/self-references.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
@@ -36,42 +36,42 @@
(define (subst var)
(intmap-ref env var (lambda (var) var)))
- (define (rename-exp label cps names vars k src exp)
- (let ((exp (rewrite-exp exp
- ((or ($ $const) ($ $prim)) ,exp)
- (($ $call proc args)
- ($call (subst proc) ,(map subst args)))
- (($ $callk k proc args)
- ($callk k (subst proc) ,(map subst args)))
- (($ $primcall name param args)
- ($primcall name param ,(map subst args)))
- (($ $branch k ($ $primcall name param args))
- ($branch k ($primcall name param ,(map subst args))))
- (($ $values args)
- ($values ,(map subst args)))
- (($ $prompt escape? tag handler)
- ($prompt escape? (subst tag) handler)))))
- (intmap-replace! cps label
- (build-cont
- ($kargs names vars ($continue k src ,exp))))))
+ (define (rename-exp exp)
+ (rewrite-exp exp
+ ((or ($ $const) ($ $prim)) ,exp)
+ (($ $call proc args)
+ ($call (subst proc) ,(map subst args)))
+ (($ $callk k proc args)
+ ($callk k (subst proc) ,(map subst args)))
+ (($ $primcall name param args)
+ ($primcall name param ,(map subst args)))
+ (($ $values args)
+ ($values ,(map subst args)))
+ (($ $prompt escape? tag handler)
+ ($prompt escape? (subst tag) handler))))
- (define (visit-exp cps label names vars k src exp)
- (match exp
- (($ $fun label)
+ (define (rename-term term)
+ (rewrite-term term
+ (($ $continue k src exp)
+ ($continue k src ,(rename-exp exp)))
+ (($ $branch kf kt src op param args)
+ ($branch kf kt src op param ,(map subst args)))))
+
+ (define (visit-label label cps)
+ (match (intmap-ref cps label)
+ (($ $kargs _ _ ($ $continue k src ($ $fun label)))
(resolve-self-references cps label env))
- (($ $rec names vars (($ $fun labels) ...))
+ (($ $kargs _ _ ($ $continue k src
+ ($ $rec names vars (($ $fun labels) ...))))
(fold (lambda (label var cps)
(match (intmap-ref cps label)
(($ $kfun src meta self)
(resolve-self-references cps label
(intmap-add env var self)))))
cps labels vars))
- (_ (rename-exp label cps names vars k src exp))))
-
- (intset-fold (lambda (label cps)
- (match (intmap-ref cps label)
- (($ $kargs names vars ($ $continue k src exp))
- (visit-exp cps label names vars k src exp))
- (_ cps)))
- (compute-function-body cps label)
- cps))
+ (($ $kargs names vars term)
+ (intmap-replace! cps label
+ (build-cont ($kargs names vars ,(rename-term term)))))
+ (_ cps)))
+
+ (intset-fold visit-label (compute-function-body cps label) cps))
diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm
index 4625569..f546583 100644
--- a/module/language/cps/simplify.scm
+++ b/module/language/cps/simplify.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
@@ -78,10 +78,10 @@
(ref* args))
(($ $values args)
(ref* args))
- (($ $branch kt ($ $primcall name param args))
- (ref* args))
(($ $prompt escape? tag handler)
(ref tag))))
+ (($ $kargs _ _ ($ $branch kf kt src op param args))
+ (ref* args))
(_
(values single multiple))))
(let*-values (((single multiple) (values empty-intset empty-intset))
@@ -144,15 +144,15 @@
(lambda (label cont)
(and (not (intset-ref label-set label))
(rewrite-cont cont
- (($ $kargs names syms ($ $continue kf src ($ $branch kt exp)))
+ (($ $kargs names syms ($ $branch kf kt src op param args))
($kargs names syms
- ($continue (subst kf) src ($branch (subst kt) ,exp))))
+ ($branch (subst kf) (subst kt) src op param args)))
(($ $kargs names syms ($ $continue k src ($ $const val)))
,(match (intmap-ref conts k)
(($ $kargs (_)
((? (lambda (var) (intset-ref singly-used var))
var))
- ($ $continue kf _ ($ $branch kt ($ $primcall 'false? #f
(var)))))
+ ($ $branch kf kt _ 'false? #f (var)))
(build-cont
($kargs names syms
($continue (subst (if val kf kt)) src ($values ())))))
@@ -189,7 +189,11 @@
(($ $ktail) (ref0))
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
(($ $kargs names syms ($ $continue k src exp))
- (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f))))))
+ (match exp
+ (($ $prompt _ _ handler) (ref2 k handler))
+ (_ (ref1 k))))
+ (($ $kargs names syms ($ $branch kf kt))
+ (ref2 kf kt))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intset-fold add-ref body single multiple)))
(intset-subtract (persistent-intset single)
@@ -235,35 +239,37 @@
(match (intmap-ref var-map var (lambda (_) #f))
(#f var)
(val (subst val))))
- (define (transform-exp label k src exp)
+ (define (transform-term label term)
(if (intset-ref label-set label)
- (match (intmap-ref conts k)
- (($ $kargs _ _ ($ $continue k* src* exp*))
- (transform-exp k k* src* exp*)))
- (build-term
- ($continue k src
- ,(rewrite-exp exp
- ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure))
- ,exp)
- (($ $call proc args)
- ($call (subst proc) ,(map subst args)))
- (($ $callk k proc args)
- ($callk k (subst proc) ,(map subst args)))
- (($ $primcall name param args)
- ($primcall name param ,(map subst args)))
- (($ $values args)
- ($values ,(map subst args)))
- (($ $branch kt ($ $primcall name param args))
- ($branch kt ($primcall name param ,(map subst args))))
- (($ $prompt escape? tag handler)
- ($prompt escape? (subst tag) handler)))))))
+ (match term
+ (($ $continue k)
+ (match (intmap-ref conts k)
+ (($ $kargs _ _ term)
+ (transform-term k term)))))
+ (rewrite-term term
+ (($ $continue k src exp)
+ ($continue k src
+ ,(rewrite-exp exp
+ ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure))
+ ,exp)
+ (($ $call proc args)
+ ($call (subst proc) ,(map subst args)))
+ (($ $callk k proc args)
+ ($callk k (subst proc) ,(map subst args)))
+ (($ $primcall name param args)
+ ($primcall name param ,(map subst args)))
+ (($ $values args)
+ ($values ,(map subst args)))
+ (($ $prompt escape? tag handler)
+ ($prompt escape? (subst tag) handler)))))
+ (($ $branch kf kt src op param args)
+ ($branch kf kt src op param ,(map subst args))))))
(transform-conts
(lambda (label cont)
- (match cont
- (($ $kargs names syms ($ $continue k src exp))
- (build-cont
- ($kargs names syms ,(transform-exp label k src exp))))
- (_ cont)))
+ (rewrite-cont cont
+ (($ $kargs names syms term)
+ ($kargs names syms ,(transform-term label term)))
+ (_ ,cont)))
conts)))
(define (simplify conts)
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index d9963e3..8abb0ea 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.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
@@ -154,12 +154,12 @@ by a label, respectively."
(return (get-defs k) (intset-add (vars->intset args) proc)))
(($ $primcall name param args)
(return (get-defs k) (vars->intset args)))
- (($ $branch kt ($ $primcall name param args))
- (return empty-intset (vars->intset args)))
(($ $values args)
(return (get-defs k) (vars->intset args)))
(($ $prompt escape? tag handler)
(return empty-intset (intset tag)))))
+ (($ $kargs _ _ ($ $branch kf kt src op param args))
+ (return empty-intset (vars->intset args)))
(($ $kclause arity body alt)
(return (get-defs body) empty-intset))
(($ $kreceive arity kargs)
@@ -238,10 +238,10 @@ body continuation in the prompt."
(visit-cont handler level (visit-cont k (1+ level) labels)))
(($ $kargs names syms ($ $continue k src ($ $primcall
'unwind)))
(visit-cont k (1- level) labels))
- (($ $kargs names syms ($ $continue k src ($ $branch kt)))
- (visit-cont k level (visit-cont kt level labels)))
(($ $kargs names syms ($ $continue k src exp))
- (visit-cont k level labels)))))))))))
+ (visit-cont k level labels))
+ (($ $kargs names syms ($ $branch kf kt))
+ (visit-cont kf level (visit-cont kt level labels))))))))))))
(define (visit-prompt label handler succs)
(let ((body (compute-prompt-body label)))
(define (out-or-back-edge? label)
@@ -629,14 +629,14 @@ are comparable with eqv?. A tmp slot may be used."
(max (+ (get-proc-slot label) nargs) size)))
(define (measure-cont label cont size)
(match cont
- (($ $kargs names vars ($ $continue k src exp))
+ (($ $kargs names vars term)
(let ((size (max-size* vars size)))
- (match exp
- (($ $call proc args)
+ (match term
+ (($ $continue _ _ ($ $call proc args))
(call-size label (1+ (length args)) size))
- (($ $callk _ proc args)
+ (($ $continue _ _ ($ $callk _ proc args))
(call-size label (1+ (length args)) size))
- (($ $values args)
+ (($ $continue _ _ ($ $values args))
(shuffle-size (get-shuffles label) size))
(_ size))))
(($ $kreceive)
@@ -744,6 +744,8 @@ are comparable with eqv?. A tmp slot may be used."
(intmap-fold
(lambda (label cont representations)
(match cont
+ (($ $kargs _ _ ($ $branch))
+ representations)
(($ $kargs _ _ ($ $continue k _ exp))
(match (get-defs k)
(() representations)
@@ -970,16 +972,16 @@ are comparable with eqv?. A tmp slot may be used."
(define (allocate-cont label cont slots call-allocs)
(match cont
- (($ $kargs names vars ($ $continue k src exp))
+ (($ $kargs names vars term)
(let-values (((slots live) (allocate-defs label vars slots)))
- (match exp
- (($ $call proc args)
+ (match term
+ (($ $continue k src ($ $call proc args))
(allocate-call label k (cons proc args) slots call-allocs live))
- (($ $callk _ proc args)
+ (($ $continue k src ($ $callk _ proc args))
(allocate-call label k (cons proc args) slots call-allocs live))
- (($ $values args)
+ (($ $continue k src ($ $values args))
(allocate-values label k args slots call-allocs))
- (($ $prompt escape? tag handler)
+ (($ $continue k src ($ $prompt escape? tag handler))
(allocate-prompt label k handler slots call-allocs))
(_
(values slots call-allocs)))))
diff --git a/module/language/cps/specialize-numbers.scm
b/module/language/cps/specialize-numbers.scm
index d8ec5e6..73fd004 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2015, 2016, 2017 Free Software Foundation, Inc.
+;; Copyright (C) 2015, 2016, 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
@@ -146,9 +146,7 @@
(define (specialize-comparison cps kf kt src op a b unbox-a unbox-b)
(with-cps cps
(letv a* b*)
- (letk kop ($kargs ('b) (b*)
- ($continue kf src
- ($branch kt ($primcall op #f (a* b*))))))
+ (letk kop ($kargs ('b) (b*) ($branch kf kt src op #f (a* b*))))
(let$ unbox-b-body (unbox-b kop src b))
(letk kunbox-b ($kargs ('a) (a*) ,unbox-b-body))
($ (unbox-a kunbox-b src a))))
@@ -157,9 +155,7 @@
unbox-a)
(with-cps cps
(letv ia)
- (letk kop ($kargs ('ia) (ia)
- ($continue kf src
- ($branch kt ($primcall op imm (ia))))))
+ (letk kop ($kargs ('ia) (ia) ($branch kf kt src op imm (ia))))
($ (unbox-a kop src a))))
(define (specialize-comparison/s64-integer cps kf kt src op a-s64 b-int
@@ -168,23 +164,19 @@
(with-cps cps
(letv a b sunk)
(letk kheap ($kargs ('sunk) (sunk)
- ($continue kf src
- ($branch kt ($primcall op #f (sunk b-int))))))
+ ($branch kf kt src op #f (sunk b-int))))
;; Re-box the variable. FIXME: currently we use a specially
;; marked s64->scm to avoid CSE from hoisting the allocation
;; again. Instead we should just use a-s64 directly and implement
;; an allocation sinking pass that should handle this..
(let$ rebox-a-body (rebox-a kheap src a))
(letk kretag ($kargs () () ,rebox-a-body))
- (letk kb ($kargs ('b) (b)
- ($continue kf src
- ($branch kt ($primcall s64-op #f (a b))))))
+ (letk kb ($kargs ('b) (b) ($branch kf kt src s64-op #f (a b))))
(letk kfix ($kargs () ()
($continue kb src
($primcall 'untag-fixnum #f (b-int)))))
(letk ka ($kargs ('a) (a)
- ($continue kretag src
- ($branch kfix ($primcall 'fixnum? #f (b-int))))))
+ ($branch kretag kfix src 'fixnum? #f (b-int))))
($ (unbox-a ka src a-s64)))))
(define (specialize-comparison/integer-s64 cps kf kt src op a-int b-s64
@@ -196,8 +188,7 @@
(with-cps cps
(letv a b sunk)
(letk kheap ($kargs ('sunk) (sunk)
- ($continue kf src
- ($branch kt ($primcall '< #f (a-int sunk))))))
+ ($branch kf kt src '< #f (a-int sunk))))
;; FIXME: We should just use b-s64 directly and implement an
;; allocation sinking pass so that the box op that creates b-64
;; should float down here. Instead, for now we just rebox the
@@ -205,25 +196,19 @@
;; CSE.
(let$ rebox-b-body (rebox-b kheap src b))
(letk kretag ($kargs () () ,rebox-b-body))
- (letk ka ($kargs ('a) (a)
- ($continue kf src
- ($branch kt ($primcall 's64-< #f (a b))))))
+ (letk ka ($kargs ('a) (a) ($branch kf kt src 's64-< #f (a b))))
(letk kfix ($kargs () ()
($continue ka src
($primcall 'untag-fixnum #f (a-int)))))
(letk kb ($kargs ('b) (b)
- ($continue kretag src
- ($branch kfix ($primcall 'fixnum? #f (a-int))))))
+ ($branch kretag kfix src 'fixnum? #f (a-int))))
($ (unbox-b kb src b-s64))))))
(define (specialize-comparison/immediate-s64-integer cps kf kt src op a b-int
compare-integers)
(with-cps cps
(letv b sunk)
- (let$ sunk-compare-exp (compare-integers sunk))
- (letk kheap ($kargs ('sunk) (sunk)
- ($continue kf src
- ($branch kt ,sunk-compare-exp))))
+ (letk kheap ($kargs ('sunk) (sunk) ,(compare-integers kf kt src sunk)))
;; Re-box the variable. FIXME: currently we use a specially marked
;; load-const to avoid CSE from hoisting the constant. Instead we
;; should just use a $const directly and implement an allocation
@@ -232,14 +217,11 @@
($continue kheap src
($primcall 'load-const/unlikely a ()))))
(letk kb ($kargs ('b) (b)
- ($continue kf src
- ($branch kt ($primcall op a (b))))))
+ ($branch kf kt src op a (b))))
(letk kfix ($kargs () ()
($continue kb src
($primcall 'untag-fixnum #f (b-int)))))
- (build-term
- ($continue kretag src
- ($branch kfix ($primcall 'fixnum? #f (b-int)))))))
+ (build-term ($branch kretag kfix src 'fixnum? #f (b-int)))))
(define (sigbits-union x y)
(and x y (logior x y)))
@@ -324,38 +306,40 @@ BITS indicating the significant bits needed for a
variable. BITS may be
(match (intmap-ref cps label)
(($ $kfun src meta self)
(add-def out self))
- (($ $kargs names vars ($ $continue k src exp))
+ (($ $kargs names vars term)
(let ((out (add-defs out vars)))
- (match exp
- ((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $rec))
- ;; No uses, so no info added to sigbits.
- out)
- (($ $values args)
- (match (intmap-ref cps k)
- (($ $kargs _ vars)
- (if (intset-ref visited k)
- (fold (lambda (arg var out)
- (intmap-add out arg (intmap-ref out var)
- sigbits-union))
- out args vars)
- out))
- (($ $ktail)
- (add-unknown-uses out args))))
- (($ $call proc args)
- (add-unknown-use (add-unknown-uses out args) proc))
- (($ $callk label proc args)
- (add-unknown-use (add-unknown-uses out args) proc))
- (($ $branch kt ($ $primcall name param args))
- (add-unknown-uses out args))
- (($ $primcall name param args)
- (let ((h (significant-bits-handler name)))
- (if h
- (match (intmap-ref cps k)
- (($ $kargs _ defs)
- (h label types out param args defs)))
+ (match term
+ (($ $continue k src exp)
+ (match exp
+ ((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $rec))
+ ;; No uses, so no info added to sigbits.
+ out)
+ (($ $values args)
+ (match (intmap-ref cps k)
+ (($ $kargs _ vars)
+ (if (intset-ref visited k)
+ (fold (lambda (arg var out)
+ (intmap-add out arg (intmap-ref out var)
+ sigbits-union))
+ out args vars)
+ out))
+ (($ $ktail)
(add-unknown-uses out args))))
- (($ $prompt escape? tag handler)
- (add-unknown-use out tag)))))
+ (($ $call proc args)
+ (add-unknown-use (add-unknown-uses out args) proc))
+ (($ $callk label proc args)
+ (add-unknown-use (add-unknown-uses out args) proc))
+ (($ $primcall name param args)
+ (let ((h (significant-bits-handler name)))
+ (if h
+ (match (intmap-ref cps k)
+ (($ $kargs _ defs)
+ (h label types out param args defs)))
+ (add-unknown-uses out args))))
+ (($ $prompt escape? tag handler)
+ (add-unknown-use out tag))))
+ (($ $branch kf kt src op param args)
+ (add-unknown-uses out args)))))
(_ out)))))))))
(define (specialize-operations cps)
@@ -623,9 +607,8 @@ BITS indicating the significant bits needed for a variable.
BITS may be
(let ((imm-op (match op ('= 's64-imm-=) ('< 'imm-s64-<))))
(specialize-comparison/immediate-s64-integer
cps kf kt src imm-op a b
- (lambda (cps a)
- (with-cps cps
- (build-exp ($primcall op #f (a b)))))))))
+ (lambda (kf kt src a)
+ (build-term ($branch kf kt src op #f (a b))))))))
(else
(specialize-comparison/s64-integer cps kf kt src op a b
(unbox-s64 a)
@@ -637,9 +620,8 @@ BITS indicating the significant bits needed for a variable.
BITS may be
(let ((imm-op (match op ('= 's64-imm-=) ('< 's64-imm-<))))
(specialize-comparison/immediate-s64-integer
cps kf kt src imm-op b a
- (lambda (cps b)
- (with-cps cps
- (build-exp ($primcall op #f (a b)))))))))
+ (lambda (kf kt src b)
+ (build-term ($branch kf kt src op #f (a b))))))))
(else
(specialize-comparison/integer-s64 cps kf kt src op a b
(unbox-s64 b)
@@ -654,8 +636,7 @@ BITS indicating the significant bits needed for a variable.
BITS may be
(sigbits (compute-significant-bits cps types label)))
(values cps types sigbits)))
- (($ $kargs names vars
- ($ $continue k src ($ $primcall op param args)))
+ (($ $kargs names vars ($ $continue k src ($ $primcall op param args)))
(call-with-values
(lambda () (specialize-primcall cps k src op param args))
(lambda (cps term)
@@ -665,8 +646,7 @@ BITS indicating the significant bits needed for a variable.
BITS may be
cps)
types sigbits))))
- (($ $kargs names vars
- ($ $continue kf src ($ $branch kt ($ $primcall op param args))))
+ (($ $kargs names vars ($ $branch kf kt src op param args))
(call-with-values
(lambda () (specialize-branch cps kf kt src op param args))
(lambda (cps term)
diff --git a/module/language/cps/split-rec.scm
b/module/language/cps/split-rec.scm
index c733c38..2f60b99 100644
--- a/module/language/cps/split-rec.scm
+++ b/module/language/cps/split-rec.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
@@ -70,29 +70,31 @@ references."
(intset-fold
(lambda (label defs uses)
(match (intmap-ref conts label)
- (($ $kargs names vars ($ $continue k src exp))
+ (($ $kargs names vars term)
(values
(add-defs vars defs)
- (match exp
- ((or ($ $const) ($ $prim)) uses)
- (($ $fun kfun)
- (intset-union (persistent-intset uses)
- (intmap-ref free kfun)))
- (($ $rec names vars (($ $fun kfun) ...))
- (fold (lambda (kfun uses)
- (intset-union (persistent-intset uses)
- (intmap-ref free kfun)))
- uses kfun))
- (($ $values args)
- (add-uses args uses))
- (($ $call proc args)
- (add-use proc (add-uses args uses)))
- (($ $branch kt ($ $primcall name param args))
- (add-uses args uses))
- (($ $primcall name param args)
- (add-uses args uses))
- (($ $prompt escape? tag handler)
- (add-use tag uses)))))
+ (match term
+ (($ $continue k src exp)
+ (match exp
+ ((or ($ $const) ($ $prim)) uses)
+ (($ $fun kfun)
+ (intset-union (persistent-intset uses)
+ (intmap-ref free kfun)))
+ (($ $rec names vars (($ $fun kfun) ...))
+ (fold (lambda (kfun uses)
+ (intset-union (persistent-intset uses)
+ (intmap-ref free kfun)))
+ uses kfun))
+ (($ $values args)
+ (add-uses args uses))
+ (($ $call proc args)
+ (add-use proc (add-uses args uses)))
+ (($ $primcall name param args)
+ (add-uses args uses))
+ (($ $prompt escape? tag handler)
+ (add-use tag uses))))
+ (($ $branch kf kt 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/type-checks.scm
b/module/language/cps/type-checks.scm
index d7503c9..029acdf 100644
--- a/module/language/cps/type-checks.scm
+++ b/module/language/cps/type-checks.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
@@ -50,14 +50,12 @@ KFUN where we can prove that no assertion will be raised at
run-time."
((causes-all-effects? fx) effects)
((causes-effect? fx &type-check)
(match (intmap-ref conts label)
- (($ $kargs _ _ exp)
- (match exp
- (($ $continue k src ($ $primcall name param args))
- (visit-primcall effects fx label name param
args))
- (($ $continue k src
- ($ $branch _ ($ $primcall name param args)))
- (visit-primcall effects fx label name param
args))
- (_ effects)))
+ (($ $kargs names vars
+ ($ $continue k src ($ $primcall name param
args)))
+ (visit-primcall effects fx label name param args))
+ (($ $kargs names vars
+ ($ $branch kf kt src name param args))
+ (visit-primcall effects fx label name param args))
(_ effects)))
(else effects))))
types
diff --git a/module/language/cps/type-fold.scm
b/module/language/cps/type-fold.scm
index f76c82e..3ac1eae 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -1,5 +1,5 @@
;;; Abstract constant folding on CPS
-;;; Copyright (C) 2014, 2015, 2017 Free Software Foundation, Inc.
+;;; Copyright (C) 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 License as
@@ -355,8 +355,7 @@
(letk kt ($kargs () () ($continue k src ($const #t))))
(letk kf ($kargs () () ($continue k src ($const #f))))
(letk ku64 ($kargs (#f) (u64)
- ($continue kt src
- ($branch kf ($primcall 's64-imm-= 0 (u64))))))
+ ($branch kt kf src 's64-imm-= 0 (u64))))
(letk kand ($kargs (#f) (res)
($continue ku64 src ($primcall 'untag-fixnum #f (res)))))
(letk kmask ($kargs (#f) (mask)
@@ -527,32 +526,32 @@
($kargs names vars
($continue (if v kt kf) src
($values ())))))))))))))))
- (define (visit-expression cps label names vars k src exp)
- (match exp
- (($ $primcall name param args)
- ;; We might be able to fold primcalls that define a value.
- (match (intmap-ref cps k)
- (($ $kargs (_) (def))
- (or (fold-primcall cps label names vars k src name param args def)
- (reduce-primcall cps label names vars k src name param args)))
- (_
- (reduce-primcall cps label names vars k src name param args))))
- (($ $branch kt ($ $primcall name param args))
- ;; We might be able to fold primcalls that branch.
- (match args
- ((x)
- (or (fold-unary-branch cps label names vars k kt src name param x)
- cps))
- ((x y)
- (or (fold-binary-branch cps label names vars k kt src name param x
y)
- cps))))
- (_ cps)))
+ (define (visit-primcall cps label names vars k src name param args)
+ ;; We might be able to fold primcalls that define a value.
+ (match (intmap-ref cps k)
+ (($ $kargs (_) (def))
+ (or (fold-primcall cps label names vars k src name param args def)
+ (reduce-primcall cps label names vars k src name param args)))
+ (_
+ (reduce-primcall cps label names vars k src name param args))))
+ (define (visit-branch cps label names vars kf kt src name param args)
+ ;; We might be able to fold primcalls that branch.
+ (match args
+ ((x)
+ (or (fold-unary-branch cps label names vars kf kt src name param x)
+ cps))
+ ((x y)
+ (or (fold-binary-branch cps label names vars kf kt src name param x y)
+ cps))))
(let lp ((label start) (cps cps))
(if (<= label end)
(lp (1+ label)
(match (intmap-ref cps label)
- (($ $kargs names vars ($ $continue k src exp))
- (visit-expression cps label names vars k src exp))
+ (($ $kargs names vars ($ $continue k src
+ ($ $primcall op param args)))
+ (visit-primcall cps label names vars k src op param args))
+ (($ $kargs names vars ($ $branch kf kt src op param args))
+ (visit-branch cps label names vars kf kt src op param args))
(_ cps)))
cps))))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 278c4e1..bb34624 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1,5 +1,5 @@
;;; Type analysis on CPS
-;;; Copyright (C) 2014, 2015, 2017 Free Software Foundation, Inc.
+;;; Copyright (C) 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 License as
@@ -1777,8 +1777,9 @@ minimum, and maximum."
(match cont
(($ $kargs _ _ ($ $continue k src exp))
(match exp
- ((or ($ $branch) ($ $prompt)) 2)
+ (($ $prompt) 2)
(_ 1)))
+ (($ $kargs _ _ ($ $branch)) 2)
(($ $kfun src meta self tail clause) (if clause 1 0))
(($ $kclause arity body alt) (if alt 2 1))
(($ $kreceive) 1)
@@ -1915,11 +1916,6 @@ maximum, where type is a bitset as a fixnum."
(values (append changed0 changed1) typev)))
;; Each of these branches must propagate to its successors.
(match exp
- (($ $branch kt ($ $primcall name param args))
- ;; The "normal" continuation is the #f branch.
- (let ((kf-types (infer-primcall types 0 name param args #f))
- (kt-types (infer-primcall types 1 name param args #f)))
- (propagate2 k kf-types kt kt-types)))
(($ $prompt escape? tag handler)
;; The "normal" continuation enters the prompt.
(propagate2 k types handler types))
@@ -1979,6 +1975,10 @@ maximum, where type is a bitset as a fixnum."
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
(visit-exp label typev k types exp))
+ (($ $kargs names vars ($ $branch kf kt src op param args))
+ ;; The "normal" continuation is the #f branch.
+ (propagate2 kf (infer-primcall types 0 op param args #f)
+ kt (infer-primcall types 1 op param args #f)))
(($ $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 3d7ac9c..cc153c2 100644
--- a/module/language/cps/utils.scm
+++ b/module/language/cps/utils.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
@@ -198,13 +198,14 @@ disjoint, an error will be signalled."
(if kalt
(visit-cont kalt (visit-cont kbody labels))
(visit-cont kbody labels)))
- (($ $kargs names syms ($ $continue k src exp))
- (visit-cont k (match exp
- (($ $branch k)
- (visit-cont k labels))
- (($ $prompt escape? tag k)
- (visit-cont k labels))
- (_ labels)))))))))))
+ (($ $kargs names syms term)
+ (match term
+ (($ $continue k src ($ $prompt escape? tag handler))
+ (visit-cont k (visit-cont handler labels)))
+ (($ $continue k)
+ (visit-cont k labels))
+ (($ $branch kf kt)
+ (visit-cont kf (visit-cont kt labels))))))))))))
(define* (compute-reachable-functions conts #:optional (kfun 0))
"Compute a mapping LABEL->LABEL..., where each key is a reachable
@@ -257,11 +258,13 @@ intset."
(if (intmap-ref succs label (lambda (_) #f))
succs
(match (intmap-ref conts label)
- (($ $kargs names vars ($ $continue k src exp))
- (match exp
- (($ $branch kt) (propagate2 k kt))
- (($ $prompt escape? tag handler) (propagate2 k handler))
- (_ (propagate1 k))))
+ (($ $kargs names vars term)
+ (match term
+ (($ $continue k src exp)
+ (match exp
+ (($ $prompt escape? tag handler) (propagate2 k handler))
+ (_ (propagate1 k))))
+ (($ $branch kf kt) (propagate2 kf kt))))
(($ $kreceive arity k)
(propagate1 k))
(($ $kfun src meta self tail clause)
@@ -291,12 +294,15 @@ intset."
preds)
(($ $kclause arity kbody kalt)
(add-pred kbody (if kalt (add-pred kalt preds) preds)))
- (($ $kargs names syms ($ $continue k src exp))
- (add-pred k
- (match exp
- (($ $branch k) (add-pred k preds))
- (($ $prompt _ _ k) (add-pred k preds))
- (_ preds))))))
+ (($ $kargs names syms term)
+ (match term
+ (($ $continue k src exp)
+ (add-pred k
+ (match exp
+ (($ $prompt _ _ k) (add-pred k preds))
+ (_ preds))))
+ (($ $branch kf kt)
+ (add-pred kf (add-pred kt 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 5dc4b84..1e05370 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -1,5 +1,5 @@
;;; Diagnostic checker for CPS
-;;; Copyright (C) 2014, 2015, 2017 Free Software Foundation, Inc.
+;;; Copyright (C) 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 License as
@@ -62,7 +62,7 @@
(intmap-fold
(lambda (label cont seen)
(match (intmap-ref conts label)
- (($ $kargs names vars ($ $continue k src exp))
+ (($ $kargs names vars term)
(fold1 adjoin-def vars seen))
(($ $kfun src meta self tail clause)
(adjoin-def self seen))
@@ -99,12 +99,15 @@ definitions that are available at LABEL."
(values (append changed0 changed1) defs)))
(match (intmap-ref conts label)
- (($ $kargs names vars ($ $continue k src exp))
+ (($ $kargs names vars term)
(let ((out (fold1 adjoin-def vars in)))
- (match exp
- (($ $branch kt) (propagate2 k kt out))
- (($ $prompt escape? tag handler) (propagate2 k handler out))
- (_ (propagate1 k out)))))
+ (match term
+ (($ $continue k src exp)
+ (match exp
+ (($ $prompt escape? tag handler) (propagate2 k handler out))
+ (_ (propagate1 k out))))
+ (($ $branch kf kt)
+ (propagate2 kf kt out)))))
(($ $kreceive arity k)
(propagate1 k in))
(($ $kfun src meta self tail clause)
@@ -159,21 +162,60 @@ definitions that are available at LABEL."
(check-use proc)
(for-each check-use args)
(visit-first-order kfun))
- (($ $branch kt ($ $primcall name param args))
- (for-each check-use args)
- first-order)
(($ $primcall name param args)
(for-each check-use args)
first-order)
(($ $prompt escape? tag handler)
(check-use tag)
first-order)))
+ (define (visit-term term bound first-order)
+ (define (check-use var)
+ (unless (intset-ref bound var)
+ (error "unbound var" var)))
+ (define (visit-first-order kfun)
+ (if (intset-ref first-order kfun)
+ first-order
+ (visit-fun kfun empty-intset (intset-add first-order kfun))))
+ (match term
+ (($ $continue k src exp)
+ (match exp
+ ((or ($ $const) ($ $prim)) first-order)
+ ;; todo: $closure
+ (($ $fun kfun)
+ (visit-fun kfun bound first-order))
+ (($ $closure kfun)
+ (visit-first-order kfun))
+ (($ $rec names vars (($ $fun kfuns) ...))
+ (let ((bound (fold1 adjoin-def vars bound)))
+ (fold1 (lambda (kfun first-order)
+ (visit-fun kfun bound first-order))
+ kfuns first-order)))
+ (($ $values args)
+ (for-each check-use args)
+ first-order)
+ (($ $call proc args)
+ (check-use proc)
+ (for-each check-use args)
+ first-order)
+ (($ $callk kfun proc args)
+ (check-use proc)
+ (for-each check-use args)
+ (visit-first-order kfun))
+ (($ $primcall name param args)
+ (for-each check-use args)
+ first-order)
+ (($ $prompt escape? tag handler)
+ (check-use tag)
+ first-order)))
+ (($ $branch kf kt src name param args)
+ (for-each check-use args)
+ first-order)))
(intmap-fold
(lambda (label bound first-order)
(let ((bound (intset-union free bound)))
(match (intmap-ref conts label)
- (($ $kargs names vars ($ $continue k src exp))
- (visit-exp exp (fold1 adjoin-def vars bound) first-order))
+ (($ $kargs names vars term)
+ (visit-term term (fold1 adjoin-def vars bound) first-order))
(_ first-order))))
(compute-available-definitions conts kfun)
first-order)))
@@ -236,11 +278,6 @@ definitions that are available at LABEL."
(assert-kreceive-or-ktail))
(($ $callk k proc args)
(assert-kreceive-or-ktail))
- (($ $branch kt exp)
- (assert-nullary)
- (match (intmap-ref conts kt)
- (($ $kargs () ()) #t)
- (cont (error "bad kt" cont))))
(($ $primcall name param args)
(match cont
(($ $kargs) #t)
@@ -254,15 +291,26 @@ definitions that are available at LABEL."
(match (intmap-ref conts handler)
(($ $kreceive) #t)
(cont (error "bad handler" cont))))))
+ (define (check-term term)
+ (match term
+ (($ $continue k src exp)
+ (check-arity exp (intmap-ref conts k)))
+ (($ $branch kf kt src op param args)
+ (match (intmap-ref conts kf)
+ (($ $kargs () ()) #t)
+ (cont (error "bad kf" cont)))
+ (match (intmap-ref conts kt)
+ (($ $kargs () ()) #t)
+ (cont (error "bad kt" cont))))))
(let ((reachable (compute-reachable-labels conts kfun)))
(intmap-for-each
(lambda (label cont)
(when (intset-ref reachable label)
(match cont
- (($ $kargs names vars ($ $continue k src exp))
+ (($ $kargs names vars term)
(unless (= (length names) (length vars))
(error "broken $kargs" label names vars))
- (check-arity exp (intmap-ref conts k)))
+ (check-term term))
(_ #t))))
conts)))
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index e66b09b..ae02113 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.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
@@ -310,9 +310,8 @@
(let$ init (convert init kreceive subst))
(letk kunbound ($kargs () () ,init))
(build-term
- ($continue kbound src
- ($branch kunbound
- ($primcall 'undefined? #f (orig-var))))))))))))))
+ ($branch kbound kunbound src
+ 'undefined? #f (orig-var))))))))))))
(define (build-list cps k src vals)
(match vals
@@ -914,14 +913,11 @@
(if (heap-type-predicate? name)
(with-cps cps
(letk kt* ($kargs () ()
- ($continue kf src
- ($branch kt ($primcall name #f args)))))
+ ($branch kf kt src name #f args)))
(build-term
- ($continue kf src
- ($branch kt* ($primcall 'heap-object? #f args)))))
+ ($branch kf kt* src 'heap-object? #f args)))
(with-cps cps
- (build-term ($continue kf src
- ($branch kt ($primcall name #f args)))))))))
+ (build-term ($branch kf kt src name #f args)))))))
(($ <conditional> src test consequent alternate)
(with-cps cps
(let$ t (convert-test consequent kt kf))
@@ -935,8 +931,7 @@
(_ (convert-arg cps test
(lambda (cps test)
(with-cps cps
- (build-term ($continue kt src
- ($branch kf ($primcall 'false? #f
(test)))))))))))
+ (build-term ($branch kt kf src 'false? #f (test)))))))))
(with-cps cps
(let$ t (convert consequent k subst))
(let$ f (convert alternate k subst))
- [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, 2018/01/03
- [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 <=