[Guile-commits] Failed: Hydra job gnu:guile-master:coverage on x86_64-linux

[Hydra Build Daemon]

Hi,

The status of Hydra job ‘gnu:guile-master:coverage’ (on x86_64-linux) has 
changed from "Failed with output" to "Failed".  For details, see

  http://hydra.nixos.org/build/22386604

This may be due to 3 commits by Herwig Hochleitner  or 
Thomas Tuegel .

Go forth and fix it.

Regards,

The Hydra build daemon.

[Guile-commits] 01/11: Fix sub/- primcall bug

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit fa7df5ed3afebb34e509f3642fb9b4a839cb2131
Author: Andy Wingo 
Date:   Wed May 20 19:18:35 2015 +0200

Fix sub/- primcall bug

* module/language/tree-il/compile-cps2.scm (convert): Fix bug
  in (apply - ...), because the instruction for "-" is "sub", and
  "sub" lookup was failing.  Caught by numbers.test.  Really I would
  like to get rid of $prim, somehow.
---
 module/language/tree-il/compile-cps2.scm |6 +++---
 1 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/module/language/tree-il/compile-cps2.scm 
b/module/language/tree-il/compile-cps2.scm
index 2f25451..4ec99c4 100644
--- a/module/language/tree-il/compile-cps2.scm
+++ b/module/language/tree-il/compile-cps2.scm
@@ -657,7 +657,7 @@
   (letk ktail ($kargs ('tail) (tail) ,body))
   ($ (lp args ktail)))
   ((prim-instruction name)
-   => (lambda (name)
+   => (lambda (instruction)
 (convert-args cps args
   (lambda (cps args)
 ;; Tree-IL primcalls are sloppy, in that it could be
@@ -665,14 +665,14 @@
 ;; arguments.  In CPS we are more strict and only
 ;; residualize a $primcall if the argument count
 ;; matches.
-(match (prim-arity name)
+(match (prim-arity instruction)
   ((out . in)
(if (= in (length args))
(with-cps cps
  (let$ k (adapt-arity k src out))
  (build-term
($continue k src
- ($primcall name args
+ ($primcall instruction args
(with-cps cps
  (letv prim)
  (letk kprim ($kargs ('prim) (prim)

[Guile-commits] 06/11: Variadic intset-fold, intmap-fold

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 5f7c8e5cb34787b6cccde785ca3887f920351d85
Author: Andy Wingo 
Date:   Tue May 19 08:18:19 2015 +0200

Variadic intset-fold, intmap-fold

* module/language/cps/intmap.scm (intmap-fold): Add two-seeded arity.
* module/language/cps/intset.scm (intset-fold): Merge intset-fold2
  into this function, as a two-seeded arity.

* module/language/cps2/simplify.scm (compute-eta-reductions):
  (compute-singly-referenced-labels, compute-beta-reductions): Adapt
  intset-fold2 callers.
---
 module/language/cps/intmap.scm|   73 --
 module/language/cps/intset.scm|  102 +++--
 module/language/cps2/simplify.scm |   10 ++--
 3 files changed, 91 insertions(+), 94 deletions(-)

diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm
index 8263f42..d453731 100644
--- a/module/language/cps/intmap.scm
+++ b/module/language/cps/intmap.scm
@@ -392,34 +392,51 @@
  (assert-readable! edit)
  (prev min shift root
 
-(define (intmap-fold f map seed)
-  (define (visit-branch node shift min seed)
-(let ((shift (- shift *branch-bits*)))
-  (if (zero? shift)
-  (let lp ((i 0) (seed seed))
-(if (< i *branch-size*)
-(let ((elt (vector-ref node i)))
-  (lp (1+ i)
-  (if (present? elt)
-  (f (+ i min) elt seed)
-  seed)))
-seed))
-  (let lp ((i 0) (seed seed))
-(if (< i *branch-size*)
-(let ((elt (vector-ref node i)))
-  (lp (1+ i)
-  (if (present? elt)
-  (visit-branch elt shift (+ min (ash i shift)) seed)
-  seed)))
-seed)
-  (match map
-(($  min shift root)
- (cond
-  ((absent? root) seed)
-  ((zero? shift) (f min root seed))
-  (else (visit-branch root shift min seed
-(($ )
- (intmap-fold f (persistent-intmap map) seed
+(define-syntax-rule (make-intmap-folder seed ...)
+  (lambda (f map seed ...)
+(define (visit-branch node shift min seed ...)
+  (let ((shift (- shift *branch-bits*)))
+(if (zero? shift)
+(let lp ((i 0) (seed seed) ...)
+  (if (< i *branch-size*)
+  (let ((elt (vector-ref node i)))
+(call-with-values (lambda ()
+(if (present? elt)
+(f (+ i min) elt seed ...)
+(values seed ...)))
+  (lambda (seed ...)
+(lp (1+ i) seed ...
+  (values seed ...)))
+(let lp ((i 0) (seed seed) ...)
+  (if (< i *branch-size*)
+  (let ((elt (vector-ref node i)))
+(call-with-values
+(lambda ()
+  (if (present? elt)
+  (visit-branch elt shift (+ min (ash i shift))
+seed ...)
+  (values seed ...)))
+  (lambda (seed ...)
+(lp (1+ i) seed ...
+  (values seed ...))
+(let fold ((map map))
+  (match map
+(($  min shift root)
+ (cond
+  ((absent? root) (values seed ...))
+  ((zero? shift) (f min root seed ...))
+  (else (visit-branch root shift min seed ...
+(($ )
+ (fold (persistent-intmap map)))
+
+(define intmap-fold
+  (case-lambda
+((f map seed)
+ ((make-intmap-folder seed) f map seed))
+((f map seed0 seed1)
+ ((make-intmap-folder seed0 seed1) f map seed0 seed1))
+((f map seed0 seed1 seed2)
+ ((make-intmap-folder seed0 seed1 seed2) f map seed0 seed1 seed2
 
 (define* (intmap-union a b #:optional (meet meet-error))
   ;; Union A and B from index I; the result will be fresh.
diff --git a/module/language/cps/intset.scm b/module/language/cps/intset.scm
index 60621d6..3276246 100644
--- a/module/language/cps/intset.scm
+++ b/module/language/cps/intset.scm
@@ -39,7 +39,6 @@
 intset-ref
 intset-next
 intset-fold
-intset-fold2
 intset-union
 intset-intersect
 intset-subtract
@@ -386,67 +385,48 @@
  (assert-readable! edit)
  (next min shift root
 
-(define (intset-fold f set seed)
-  (define (visit-branch node shift min seed)
-(cond
- ((= shift *leaf-bits*)
-  (let lp ((i 0) (seed seed))
-(if (< i *leaf-size*)
-(lp (1+ i)
-(if (logbit? i node)
-(f (+ i min) seed)
-seed))
-seed)))
- (else
-  (let ((shift (- shift *branch-bi

[Guile-commits] 03/11: Fix bug compiling fixpoint combinator

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 4632f3d9988f9a234298b7cc860b2374e2bcc712
Author: Andy Wingo 
Date:   Wed May 20 17:20:25 2015 +0200

Fix bug compiling fixpoint combinator

* module/language/tree-il/peval.scm (): Rename "alias-value"
  field to "alias", which is now an operand and not an expression.
  This allows the operand to capture its environment; before, the
  alias was being visited in its use environment instead of its
  definition environment.
  (peval): Adapt to operand change.  Fix construction of rest bindings
  as well.
* test-suite/tests/peval.test ("partial evaluation"): New test.
---
 module/language/tree-il/peval.scm |   22 ++
 test-suite/tests/peval.test   |   30 --
 2 files changed, 38 insertions(+), 14 deletions(-)

diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index 3daa2ec..fca849e 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -275,7 +275,7 @@
 ;; 
 (define-record-type 
   (%make-operand var sym visit source visit-count use-count
- copyable? residual-value constant-value alias-value)
+ copyable? residual-value constant-value alias)
   operand?
   (var operand-var)
   (sym operand-sym)
@@ -286,7 +286,7 @@
   (copyable? operand-copyable? set-operand-copyable?!)
   (residual-value operand-residual-value %set-operand-residual-value!)
   (constant-value operand-constant-value set-operand-constant-value!)
-  (alias-value operand-alias-value set-operand-alias-value!))
+  (alias operand-alias set-operand-alias!))
 
 (define* (make-operand var sym #:optional source visit alias)
   ;; Bind SYM to VAR, with value SOURCE.  Unassigned bound operands are
@@ -787,16 +787,16 @@ top-level bindings from ENV and return the resulting 
expression."
  (else exp)))
   (($  _ _ gensym)
(log 'begin-copy gensym)
-   (let ((op (lookup gensym)))
+   (let lp ((op (lookup gensym)))
  (cond
   ((eq? ctx 'effect)
(log 'lexical-for-effect gensym)
(make-void #f))
-  ((operand-alias-value op)
+  ((operand-alias op)
;; This is an unassigned operand that simply aliases some
;; other operand.  Recurse to avoid residualizing the leaf
;; binding.
-   => for-tail)
+   => lp)
   ((eq? ctx 'call)
;; Don't propagate copies if we are residualizing a call.
(log 'residualize-lexical-call gensym op)
@@ -913,7 +913,7 @@ top-level bindings from ENV and return the resulting 
expression."
  (map (cut make-lexical-ref #f <> <>)
   tmps tmp-syms)))
   (($  src names gensyms vals body)
-   (define (compute-alias exp)
+   (define (lookup-alias exp)
  ;; It's very common for macros to introduce something like:
  ;;
  ;;   ((lambda (x y) ...) x-exp y-exp)
@@ -933,9 +933,7 @@ top-level bindings from ENV and return the resulting 
expression."
  (match exp
(($  _ _ sym)
 (let ((op (lookup sym)))
-  (and (not (var-set? (operand-var op)))
-   (or (operand-alias-value op)
-   exp
+  (and (not (var-set? (operand-var op))) op)))
(_ #f)))
 
(let* ((vars (map lookup-var gensyms))
@@ -943,7 +941,7 @@ top-level bindings from ENV and return the resulting 
expression."
   (ops (make-bound-operands vars new vals
 (lambda (exp counter ctx)
   (loop exp env counter ctx))
-(map compute-alias vals)))
+(map lookup-alias vals)))
   (env (fold extend-env env gensyms ops))
   (body (loop body env counter ctx)))
  (cond
@@ -1397,8 +1395,8 @@ top-level bindings from ENV and return the resulting 
expression."
(list (make-primcall
   #f 'list
   (drop orig-args (+ nreq nopt)
-  (rest (list (make-const #f '(
-  (else '()
+  ((null? rest) '())
+  (else (list (make-const #f '()))
   (if (>= nargs (+ nreq nopt))
   (make-let src
 (append req opt rest)
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 7cc5a31..93988af 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1372,9 +1372,35 @@
 (if (pair? arg)
 (set! l arg))
 (apply f l))
-(let (l) (_) ((const

[Guile-commits] 07/11: Add arity to worklist-fold

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 1403df4140759397a219f793b4fcbcb35937b033
Author: Andy Wingo 
Date:   Tue May 19 08:38:24 2015 +0200

Add arity to worklist-fold

* module/language/cps2/utils.scm (worklist-fold): Add two-seeded arity.
  (worklist-fold2): Remove.

* module/language/cps2/renumber.scm (compute-tail-path-lengths): Adapt.
---
 module/language/cps2/renumber.scm |2 +-
 module/language/cps2/utils.scm|   27 +--
 2 files changed, 14 insertions(+), 15 deletions(-)

diff --git a/module/language/cps2/renumber.scm 
b/module/language/cps2/renumber.scm
index d114d5a..f7e9eb6 100644
--- a/module/language/cps2/renumber.scm
+++ b/module/language/cps2/renumber.scm
@@ -55,7 +55,7 @@
   (values (compute-next labels lengths) lengths (1+ length
   (match (intmap-ref conts kfun)
 (($ $kfun src meta self tail clause)
- (worklist-fold2 visit (intset-add empty-intset tail) empty-intmap 0
+ (worklist-fold visit (intset-add empty-intset tail) empty-intmap 0
 
 ;; Topologically sort the continuation tree starting at k0, using
 ;; reverse post-order numbering.
diff --git a/module/language/cps2/utils.scm b/module/language/cps2/utils.scm
index c7b7707..c1fcd39 100644
--- a/module/language/cps2/utils.scm
+++ b/module/language/cps2/utils.scm
@@ -38,7 +38,7 @@
 ;; Various utilities.
 fold1 fold2
 intset->intmap
-worklist-fold worklist-fold2
+worklist-fold
 fixpoint
 
 ;; Flow analysis.
@@ -108,19 +108,18 @@
   (intmap-add! preds label (f label)))
 set empty-intmap)))
 
-(define (worklist-fold f in out)
-  (if (eq? in empty-intset)
-  out
-  (call-with-values (lambda () (f in out))
-(lambda (in out)
-  (worklist-fold f in out)
-
-(define (worklist-fold2 f in out0 out1)
-  (if (eq? in empty-intset)
-  (values out0 out1)
-  (call-with-values (lambda () (f in out0 out1))
-(lambda (in out0 out1)
-  (worklist-fold2 f in out0 out1)
+(define worklist-fold
+  (case-lambda
+((f in out)
+ (let lp ((in in) (out out))
+   (if (eq? in empty-intset)
+   out
+   (call-with-values (lambda () (f in out)) lp
+((f in out0 out1)
+ (let lp ((in in) (out0 out0) (out1 out1))
+   (if (eq? in empty-intset)
+   (values out0 out1)
+   (call-with-values (lambda () (f in out0 out1)) lp))
 
 (define fixpoint
   (case-lambda

[Guile-commits] 09/11: Fix bug in CPS2 simplify's "transform-conts"

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 7d4ede040d06fcd0fc86cc373505a8550a41b06d
Author: Andy Wingo 
Date:   Wed May 20 11:37:28 2015 +0200

Fix bug in CPS2 simplify's "transform-conts"

* module/language/cps2/simplify.scm (transform-conts): Return a persistent 
intmap.
---
 module/language/cps2/simplify.scm |   15 ---
 1 files changed, 8 insertions(+), 7 deletions(-)

diff --git a/module/language/cps2/simplify.scm 
b/module/language/cps2/simplify.scm
index 43960c6..7416aa2 100644
--- a/module/language/cps2/simplify.scm
+++ b/module/language/cps2/simplify.scm
@@ -53,13 +53,14 @@
   (((x1 . l1) . (x2 . l2)) (lp l1 l2 (f x1 x2 seed))
 
 (define (transform-conts f conts)
-  (intmap-fold (lambda (k v out)
- (let ((v* (f k v)))
-   (if (equal? v v*)
-   out
-   (intmap-add! out k v* (lambda (old new) new)
-   conts
-   conts))
+  (persistent-intmap
+   (intmap-fold (lambda (k v out)
+  (let ((v* (f k v)))
+(if (equal? v v*)
+out
+(intmap-add! out k v* (lambda (old new) new)
+conts
+conts)))
 
 ;;; Continuations that simply forward their values to another may be
 ;;; elided via eta reduction over labels.

[Guile-commits] 05/11: Intmaps do not treat #f specially as a value

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 2b06e90ca40e556471fa00241861b3d90eef932b
Author: Andy Wingo 
Date:   Thu May 14 13:46:09 2015 +0200

Intmaps do not treat #f specially as a value

* module/language/cps/intmap.scm: Intmaps can now contain any value;
  #f does not indicate the absence of a value.  Instead we use a unique
  private sentinel to mark absent values or branches.
  (*absent*, absent?, present?): New helpers.
  (new-branch): Initialize empty elements to *absent*.
  (clone-branch-with-edit): New helper.
  (clone-branch-and-set): Use clone-branch-with-edit.
  (writable-branch): Use clone-branch-with-edit
  (empty-intmap): Initialize value to *absent*.
  (add-level): clone-branch-and-set doesn't take #f as a branch any
  more; use new-branch.
  (branch-empty?, make-intmap/prune, intmap-add!):
  (intmap-add, intmap-remove, intmap-next, intmap-prev):
  (intmap-fold, intmap-union, intmap-intersect): Use absent? to detect
  absent branches / values.
  (intmap-ref): Likewise.  Instead of returning #f if the value is not
  found, call the optional not-found procedure.  By default this will
  signal an error.

* module/language/cps/types.scm:
* module/language/cps2/renumber.scm:
* module/language/cps2/simplify.scm: Adapt to intmap-ref signalling an
  error by default if the value is not found.

* module/language/tree-il/compile-cps2.scm: Adapt to intmap-add
  signalling an error if #f was in the intmap as a value.
---
 module/language/cps/intmap.scm   |  252 --
 module/language/cps/types.scm|2 +-
 module/language/cps2/renumber.scm|   14 +-
 module/language/cps2/simplify.scm|2 +-
 module/language/tree-il/compile-cps2.scm |3 +-
 5 files changed, 144 insertions(+), 129 deletions(-)

diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm
index 9081f33..8263f42 100644
--- a/module/language/cps/intmap.scm
+++ b/module/language/cps/intmap.scm
@@ -84,13 +84,22 @@
   (root transient-intmap-root set-transient-intmap-root!)
   (edit transient-intmap-edit set-transient-intmap-edit!))
 
+(define *absent* (list 'absent))
+(define-inlinable (absent? x)
+  (eq? x *absent*))
+(define-inlinable (present? x)
+  (not (absent? x)))
+
 (define-inlinable (new-branch edit)
-  (let ((vec (make-vector *branch-size-with-edit* #f)))
-(when edit (vector-set! vec *edit-index* edit))
+  (let ((vec (make-vector *branch-size-with-edit* *absent*)))
+(vector-set! vec *edit-index* edit)
 vec))
+(define-inlinable (clone-branch-with-edit branch edit)
+  (let ((new (vector-copy branch)))
+(vector-set! new *edit-index* edit)
+new))
 (define (clone-branch-and-set branch i elt)
-  (let ((new (new-branch #f)))
-(when branch (vector-move-left! branch 0 *branch-size* new 0))
+  (let ((new (clone-branch-with-edit branch #f)))
 (vector-set! new i elt)
 new))
 (define-inlinable (assert-readable! root-edit)
@@ -100,24 +109,26 @@
   (let ((edit (vector-ref branch *edit-index*)))
 (if (eq? root-edit edit)
 branch
-(clone-branch-and-set branch *edit-index* root-edit
+(clone-branch-with-edit branch root-edit
 (define (branch-empty? branch)
   (let lp ((i 0))
 (or (= i *branch-size*)
-(and (not (vector-ref branch i))
+(and (absent? (vector-ref branch i))
  (lp (1+ i))
 
 (define-inlinable (round-down min shift)
   (logand min (lognot (1- (ash 1 shift)
 
-(define empty-intmap (make-intmap 0 0 #f))
+(define empty-intmap (make-intmap 0 0 *absent*))
 
 (define (add-level min shift root)
   (let* ((shift* (+ shift *branch-bits*))
  (min* (round-down min shift*))
  (idx (logand (ash (- min min*) (- shift))
-  *branch-mask*)))
-(make-intmap min* shift* (clone-branch-and-set #f idx root
+  *branch-mask*))
+ (root* (new-branch #f)))
+(vector-set! root* idx root)
+(make-intmap min* shift* root*)))
 
 (define (make-intmap/prune min shift root)
   (if (zero? shift)
@@ -125,7 +136,7 @@
   (let lp ((i 0) (elt #f))
 (cond
  ((< i *branch-size*)
-  (if (vector-ref root i)
+  (if (present? (vector-ref root i))
   (if elt
   (make-intmap min shift root)
   (lp (1+ i) i))
@@ -169,25 +180,24 @@
 
 (define* (intmap-add! map i val #:optional (meet meet-error))
   (define (ensure-branch! root idx)
-(let ((edit (vector-ref root *edit-index*)))
-  (match (vector-ref root idx)
-(#f (let ((v (new-branch edit)))
-  (vector-set! root idx v)
-  v))
-(v (let ((v* (writable-branch v edit)))
- (unless (eq? v v*)
-   (vector-set! root idx v*))
- v*)
+(let ((edit (vector-ref root *edit-index*))
+  

[Guile-commits] 10/11: Port effects analysis to CPS2

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 80c162b67cdc546ad9908a6023c3331a934ab7a7
Author: Andy Wingo 
Date:   Thu May 14 16:35:26 2015 +0200

Port effects analysis to CPS2

* module/Makefile.am (CPS2_LANG_SOURCES): Add effects-analysis.scm.
* module/language/cps2/effects-analysis.scm: New file, based on
  cps/effects-analysis.scm.
* module/language/cps2/utils.scm (intmap-map):
  (compute-defining-expressions, compute-constant-values): New helpers.
---
 module/Makefile.am|1 +
 module/language/cps2/effects-analysis.scm |  484 +
 module/language/cps2/utils.scm|   39 +++-
 3 files changed, 523 insertions(+), 1 deletions(-)

diff --git a/module/Makefile.am b/module/Makefile.am
index 145b04f..6c6830f 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -149,6 +149,7 @@ CPS_LANG_SOURCES =  
\
 CPS2_LANG_SOURCES =\
   language/cps2.scm\
   language/cps2/compile-cps.scm\
+  language/cps2/effects-analysis.scm   \
   language/cps2/renumber.scm   \
   language/cps2/optimize.scm   \
   language/cps2/simplify.scm   \
diff --git a/module/language/cps2/effects-analysis.scm 
b/module/language/cps2/effects-analysis.scm
new file mode 100644
index 000..a41c5f2
--- /dev/null
+++ b/module/language/cps2/effects-analysis.scm
@@ -0,0 +1,484 @@
+;;; Effects analysis on CPS
+
+;; Copyright (C) 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+ License as published by the Free Software Foundation; either
+ version 3 of the License, or (at your option) any later version.
+ 
+ This library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ Lesser General Public License for more details.
+ 
+ You should have received a copy of the GNU Lesser General Public
+ License along with this library; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 
USA
+
+;;; Commentary:
+;;;
+;;; A helper module to compute the set of effects caused by an
+;;; expression.  This information is useful when writing algorithms that
+;;; move code around, while preserving the semantics of an input
+;;; program.
+;;;
+;;; The effects set is represented as an integer with three parts.  The
+;;; low 4 bits indicate effects caused by an expression, as a bitfield.
+;;; The next 4 bits indicate the kind of memory accessed by the
+;;; expression, if it accesses mutable memory.  Finally the rest of the
+;;; bits indicate the field in the object being accessed, if known, or
+;;; -1 for unknown.
+;;;
+;;; In this way we embed a coarse type-based alias analysis in the
+;;; effects analysis.  For example, a "car" call is modelled as causing
+;;; a read to field 0 on a &pair, and causing a &type-check effect.  If
+;;; any intervening code sets the car of any pair, that will block
+;;; motion of the "car" call, because any write to field 0 of a pair is
+;;; seen by effects analysis as being a write to field 0 of all pairs.
+;;;
+;;; Code:
+
+(define-module (language cps2 effects-analysis)
+  #:use-module (language cps2)
+  #:use-module (language cps2 utils)
+  #:use-module (language cps intmap)
+  #:use-module (ice-9 match)
+  #:export (expression-effects
+compute-effects
+synthesize-definition-effects
+
+&allocation
+&type-check
+&read
+&write
+
+&fluid
+&prompt
+&car
+&cdr
+&vector
+&box
+&module
+&struct
+&string
+&bytevector
+
+&object
+&field
+
+&allocate
+&read-object
+&read-field
+&write-object
+&write-field
+
+&no-effects
+&all-effects
+
+exclude-effects
+effect-free?
+constant?
+causes-effect?
+causes-all-effects?
+effect-clobbers?))
+
+(define-syntax define-flags
+  (lambda (x)
+(syntax-case x ()
+  ((_ all shift name ...)
+   (let ((count (length #'(name ...
+ (with-syntax (((n ...) (iota count))
+   (count count))
+   #'(begin
+   (define-syntax name (identifier-syntax (ash 1 n)))
+   ...
+   (define-syntax all (identifier-sy

[Guile-commits] 02/11: Fix fixpoint

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit e0e47cb527a09e8d3d28beead1cd50f2ee015b03
Author: Andy Wingo 
Date:   Mon May 18 21:21:53 2015 +0200

Fix fixpoint

* module/language/cps2/utils.scm (fixpoint): Fix embarrassing bug
  where it wouldn't actually fixpoint!  Didn't show up in practice
  because CPS2 hasn't run after contification yet.
---
 module/language/cps2/utils.scm |2 +-
 1 files changed, 1 insertions(+), 1 deletions(-)

diff --git a/module/language/cps2/utils.scm b/module/language/cps2/utils.scm
index d07356b..d5955c3 100644
--- a/module/language/cps2/utils.scm
+++ b/module/language/cps2/utils.scm
@@ -124,7 +124,7 @@
 
 (define (fixpoint f x)
   (let ((x* (f x)))
-(if (eq? x x*) x* (f x*
+(if (eq? x x*) x* (fixpoint f x*
 
 (define (compute-function-body conts kfun)
   (persistent-intset

[Guile-commits] 04/11: Add two-argument fixpoint arity

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit cb7aa0b3b13b3f9c8dfba3a044d9e97e9dcd8c68
Author: Andy Wingo 
Date:   Tue May 19 08:34:30 2015 +0200

Add two-argument fixpoint arity

* module/language/cps2/utils.scm (fixpoint): Add two-argument arity.
---
 module/language/cps2/utils.scm |   16 +---
 1 files changed, 13 insertions(+), 3 deletions(-)

diff --git a/module/language/cps2/utils.scm b/module/language/cps2/utils.scm
index d5955c3..c7b7707 100644
--- a/module/language/cps2/utils.scm
+++ b/module/language/cps2/utils.scm
@@ -122,9 +122,19 @@
 (lambda (in out0 out1)
   (worklist-fold2 f in out0 out1)
 
-(define (fixpoint f x)
-  (let ((x* (f x)))
-(if (eq? x x*) x* (fixpoint f x*
+(define fixpoint
+  (case-lambda
+((f x)
+ (let lp ((x x))
+   (let ((x* (f x)))
+ (if (eq? x x*) x* (lp x*)
+((f x0 x1)
+ (let lp ((x0 x0) (x1 x1))
+   (call-with-values (lambda () (f x0 x1))
+ (lambda (x0* x1*)
+   (if (and (eq? x0 x0*) (eq? x1 x1*))
+   (values x0* x1*)
+   (lp x0* x1*
 
 (define (compute-function-body conts kfun)
   (persistent-intset

[Guile-commits] 08/11: intmaps and intsets print with abbreviated key ranges

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 102e677b982fc1903b05c50b239a9f51d2e124f4
Author: Andy Wingo 
Date:   Tue May 19 10:19:02 2015 +0200

intmaps and intsets print with abbreviated key ranges

* module/language/cps/intset.scm (intset-key-ranges, range-string):
  (print-helper, print-intset, print-transient-intset): New helpers.
  Install as intset printers.
* module/language/cps/intmap.scm (intmap-key-ranges, range-string):
  (print-helper): New helpers.
  (print-intmap, print-transient-intmap): Call the new helpers.
---
 module/language/cps/intmap.scm |   38 +-
 module/language/cps/intset.scm |   43 
 2 files changed, 79 insertions(+), 2 deletions(-)

diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm
index d453731..cb56cb3 100644
--- a/module/language/cps/intmap.scm
+++ b/module/language/cps/intmap.scm
@@ -629,10 +629,44 @@
 (define (intmap->alist intmap)
   (reverse (intmap-fold acons intmap '(
 
+(define (intmap-key-ranges intmap)
+  (call-with-values
+  (lambda ()
+(intmap-fold (lambda (k v start end closed)
+   (cond
+((not start) (values k k closed))
+((= k (1+ end)) (values start k closed))
+(else (values k k (acons start end closed)
+ intmap #f #f '()))
+(lambda (start end closed)
+  (reverse (if start (acons start end closed) closed)
+
+(define (range-string ranges)
+  (string-join (map (match-lambda
+  ((start . start)
+   (format #f "~a" start))
+  ((start . end)
+   (format #f "~a-~a" start end)))
+ranges)
+   ","))
+
+(define (print-helper port tag intmap)
+  (let ((ranges (intmap-key-ranges intmap)))
+(match ranges
+  (()
+   (format port "#<~a>" tag))
+  (((0 . _) . _)
+   (format port "#<~a ~a>" tag (range-string ranges)))
+  (((min . end) . ranges)
+   (let ((ranges (map (match-lambda
+((start . end) (cons (- start min) (- end min
+  (acons min end ranges
+ (format port "#<~a ~a+~a>" tag min (range-string ranges)))
+
 (define (print-intmap intmap port)
-  (format port "#" (intmap->alist intmap)))
+  (print-helper port "intmap" intmap))
 (define (print-transient-intmap intmap port)
-  (format port "#" (intmap->alist intmap)))
+  (print-helper port "transient-intmap" intmap))
 
 (set-record-type-printer!  print-intmap)
 (set-record-type-printer!  print-transient-intmap)
diff --git a/module/language/cps/intset.scm b/module/language/cps/intset.scm
index 3276246..3d20797 100644
--- a/module/language/cps/intset.scm
+++ b/module/language/cps/intset.scm
@@ -27,6 +27,7 @@
 (define-module (language cps intset)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
   #:use-module (ice-9 match)
   #:export (empty-intset
 intset?
@@ -731,3 +732,45 @@
 (let ((min* (round-down pos *leaf-bits*)))
   (lp (finish-tail out min tail)
   min* pos (ash 1 (- pos min*)
+
+(define (intset-key-ranges intset)
+  (call-with-values
+  (lambda ()
+(intset-fold (lambda (k start end closed)
+   (cond
+((not start) (values k k closed))
+((= k (1+ end)) (values start k closed))
+(else (values k k (acons start end closed)
+ intset #f #f '()))
+(lambda (start end closed)
+  (reverse (if start (acons start end closed) closed)
+
+(define (range-string ranges)
+  (string-join (map (match-lambda
+  ((start . start)
+   (format #f "~a" start))
+  ((start . end)
+   (format #f "~a-~a" start end)))
+ranges)
+   ","))
+
+(define (print-helper port tag intset)
+  (let ((ranges (intset-key-ranges intset)))
+(match ranges
+  (()
+   (format port "#<~a>" tag))
+  (((0 . _) . _)
+   (format port "#<~a ~a>" tag (range-string ranges)))
+  (((min . end) . ranges)
+   (let ((ranges (map (match-lambda
+((start . end) (cons (- start min) (- end min
+  (acons min end ranges
+ (format port "#<~a ~a+~a>" tag min (range-string ranges)))
+
+(define (print-intset intset port)
+  (print-helper port "intset" intset))
+(define (print-transient-intset intset port)
+  (print-helper port "transient-intset" intset))
+
+(set-record-type-printer!  print-intset)
+(set-record-type-printer!  print-transient-intset)

[Guile-commits] 11/11: Port dead code elimination (DCE) pass to CPS2

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 48b2f190b2661c329ec95dee83b8eb08f605f25e
Author: Andy Wingo 
Date:   Wed May 20 11:36:57 2015 +0200

Port dead code elimination (DCE) pass to CPS2

* module/language/cps2/dce.scm: New file.
* module/language/cps2/optimize.scm: Enable CPS2 DCE pass.
* module/Makefile.am: Add language/cps2/dce.scm.
---
 module/Makefile.am|1 +
 module/language/cps2/dce.scm  |  403 +
 module/language/cps2/optimize.scm |2 +
 3 files changed, 406 insertions(+), 0 deletions(-)

diff --git a/module/Makefile.am b/module/Makefile.am
index 6c6830f..fe49d17 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -149,6 +149,7 @@ CPS_LANG_SOURCES =  
\
 CPS2_LANG_SOURCES =\
   language/cps2.scm\
   language/cps2/compile-cps.scm\
+  language/cps2/dce.scm\
   language/cps2/effects-analysis.scm   \
   language/cps2/renumber.scm   \
   language/cps2/optimize.scm   \
diff --git a/module/language/cps2/dce.scm b/module/language/cps2/dce.scm
new file mode 100644
index 000..1f7086a
--- /dev/null
+++ b/module/language/cps2/dce.scm
@@ -0,0 +1,403 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+ License as published by the Free Software Foundation; either
+ version 3 of the License, or (at your option) any later version.
+
+ This library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with this library; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 
USA
+
+;;; Commentary:
+;;;
+;;; This pass kills dead expressions: code that has no side effects, and
+;;; whose value is unused.  It does so by marking all live values, and
+;;; then discarding other values as dead.  This happens recursively
+;;; through procedures, so it should be possible to elide dead
+;;; procedures as well.
+;;;
+;;; Code:
+
+(define-module (language cps2 dce)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (language cps2)
+  #:use-module (language cps2 effects-analysis)
+  #:use-module (language cps2 renumber)
+  ;; #:use-module (language cps2 types)
+  #:use-module (language cps2 utils)
+  #:use-module (language cps intmap)
+  #:use-module (language cps intset)
+  #:export (eliminate-dead-code))
+
+(define (elide-type-checks conts effects)
+  "Given CONTS, an intmap of the conts in one local function, remove any
+&type-check effect from EFFECTS where we can prove that no assertion
+will be raised at run-time."
+  #;
+  (let ((types (infer-types conts)))
+(define (visit-primcall effects fx label name args)
+  (if (primcall-types-check? types label name args)
+  (intmap-add! effects label (logand fx (lognot &type-check))
+   (lambda (old new) new))
+  effects))
+(persistent-intmap
+ (intmap-fold (lambda (label cont effects)
+(let ((fx (intmap-ref effects label)))
+  (cond
+   ((causes-all-effects? fx) effects)
+   ((causes-effect? fx &type-check)
+(match cont
+  (($ $kargs _ _ exp)
+   (match exp
+ (($ $continue k src ($ $primcall name args))
+  (visit-primcall effects fx label name args))
+ (($ $continue k src ($ $branch _ ($primcall name 
args)))
+  (visit-primcall effects fx label name args))
+ (_ effects)))
+  (_ effects)))
+   (else effects
+  conts
+  effects)))
+  effects)
+
+(define (fold-local-conts proc conts label seed)
+  (match (intmap-ref conts label)
+(($ $kfun src meta self tail clause)
+ (let lp ((label label) (seed seed))
+   (if (<= label tail)
+   (lp (1+ label) (proc label (intmap-ref conts label) seed))
+   seed)
+
+(define (postorder-fold-local-conts2 proc conts label seed0 seed1)
+  (match (intmap-ref conts label)
+(($ $kfun src me

[Guile-commits] branch master updated (ef5f2fc -> 48b2f19)

[Andy Wingo]

wingo pushed a change to branch master
in repository guile.

  from  ef5f2fc   Add optimization pass over CPS2
   new  fa7df5e   Fix sub/- primcall bug
   new  e0e47cb   Fix fixpoint
   new  4632f3d   Fix bug compiling fixpoint combinator
   new  cb7aa0b   Add two-argument fixpoint arity
   new  2b06e90   Intmaps do not treat #f specially as a value
   new  5f7c8e5   Variadic intset-fold, intmap-fold
   new  1403df4   Add arity to worklist-fold
   new  102e677   intmaps and intsets print with abbreviated key ranges
   new  7d4ede0   Fix bug in CPS2 simplify's "transform-conts"
   new  80c162b   Port effects analysis to CPS2
   new  48b2f19   Port dead code elimination (DCE) pass to CPS2

The 11 revisions listed above as "new" are entirely new to this
repository and will be described in separate emails.  The revisions
listed as "adds" were already present in the repository and have only
been added to this reference.


Summary of changes:
 module/Makefile.am |2 +
 module/language/cps/intmap.scm |  357 ++---
 module/language/cps/intset.scm |  147 ---
 module/language/cps/types.scm  |2 +-
 module/language/cps2/dce.scm   |  403 
 module/language/{cps => cps2}/effects-analysis.scm |  141 +++
 module/language/cps2/optimize.scm  |2 +
 module/language/cps2/renumber.scm  |   16 +-
 module/language/cps2/simplify.scm  |   27 +-
 module/language/cps2/utils.scm |   84 -
 module/language/tree-il/compile-cps2.scm   |9 +-
 module/language/tree-il/peval.scm  |   22 +-
 test-suite/tests/peval.test|   30 ++-
 13 files changed, 897 insertions(+), 345 deletions(-)
 create mode 100644 module/language/cps2/dce.scm
 copy module/language/{cps => cps2}/effects-analysis.scm (82%)

[Guile-commits] Failed with output: Hydra job gnu:guile-master:coverage on x86_64-linux

[Hydra Build Daemon]

Hi,

The status of Hydra job ‘gnu:guile-master:coverage’ (on x86_64-linux) has 
changed from "Failed" to "Failed with output".  For details, see

  http://hydra.nixos.org/build/22387345

This may be due to 5 commits by Tobias Geerinckx-Rice 
 or William A. Kennington III 
.

Go forth and fix it.

Regards,

The Hydra build daemon.

[Guile-commits] Failed with output: Hydra job gnu:guile-master:coverage on x86_64-linux

[Hydra Build Daemon]

Hi,

The status of Hydra job ‘gnu:guile-master:coverage’ (on x86_64-linux) has 
changed from "Failed" to "Failed with output".  For details, see

  http://hydra.nixos.org/build/22386827

This may be due to 2 commits by Tobias Geerinckx-Rice 
.

Go forth and fix it.

Regards,

The Hydra build daemon.