[Guile-commits] GNU Guile branch, master, updated. v2.1.0-17-g6119a90

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=6119a9059543e1985b8dd504e70d7a690db62ec2

The branch, master has been updated
       via  6119a9059543e1985b8dd504e70d7a690db62ec2 (commit)
       via  cfb42b4c8a391446fc6c2a8c41dfd8ad0489fda7 (commit)
       via  e15f3e3328dc79ceeb8dacbfba6fed056ae7bfef (commit)
      from  9de674e6e63ed1576c5b0660ac709f430822dbcf (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 6119a9059543e1985b8dd504e70d7a690db62ec2
Author: Andy Wingo <address@hidden>
Date:   Fri May 2 17:47:20 2014 +0200

    CSE does scalar replacement of aggregates
    
    * module/language/cps/effects-analysis.scm (effects-clobber): New
      helper.
      (length): Only depend on &cdr.
      (synthesize-definition-effects!): New interface.
    
    * module/language/cps/cse.scm (compute-available-expressions): Don't
      count out constructors here -- we'll do that below.
      (compute-defs): Add a comment.
      (compute-equivalent-subexpressions): Synthesize getter calls at
      constructor/setter sites, so that (set-car! x y) can cause a
      future (car x) to just reference y.  The equiv-labels set now stores
      the defined vars, so there is no need for the defs vector.
      (cse, apply-cse): Adapt to compute-equivalent-subexpressions change.

commit cfb42b4c8a391446fc6c2a8c41dfd8ad0489fda7
Author: Andy Wingo <address@hidden>
Date:   Fri May 2 17:29:39 2014 +0200

    More inlinable effects-analysis procedures
    
    * module/language/cps/effects-analysis.scm (exclude-effects)
      (effect-free?, constant?): Define to be inlinable.
      (allocate-struct/immediate): Add effects.

commit e15f3e3328dc79ceeb8dacbfba6fed056ae7bfef
Author: Andy Wingo <address@hidden>
Date:   Fri May 2 11:13:34 2014 +0200

    Update NEWS
    
    * NEWS: Update.

-----------------------------------------------------------------------

Summary of changes:
 NEWS                                     |   65 +++++++++++++++---
 module/language/cps/cse.scm              |  110 ++++++++++++++++++++++--------
 module/language/cps/effects-analysis.scm |   51 +++++++++++++-
 3 files changed, 184 insertions(+), 42 deletions(-)

diff --git a/NEWS b/NEWS
index 2c13fb7..408f3f9 100644
--- a/NEWS
+++ b/NEWS
@@ -25,13 +25,28 @@ Notably, weak hash tables are now transparently 
thread-safe.  Ports are
 also thread-safe; see "New interfaces" below for details on the changes
 to the C interface.
 
+** Better space-safety
+
+It used to be the case that, when calling a Scheme procedure, the
+procedure and arguments were always preserved against garbage
+collection.  This is no longer the case; Guile is free to collect the
+procedure and arguments if they become unreachable, or to re-use their
+slots for other local variables.  Guile still offers good-quality
+backtraces by determining the procedure being called from the
+instruction pointer instead of from the value in slot 0 of an
+application frame, and by using a live variable map that allows the
+debugger to know which locals are live at all points in a frame.
+
 ** Off-main-thread finalization
 
 Following Guile 2.0.6's change to invoke finalizers via asyncs, Guile
 2.2 takes the additional step of invoking finalizers from a dedicated
 finalizer thread, if threads are enabled.  This avoids concurrency
 issues between finalizers and application code, and also speeds up
-finalization.
+finalization.  If your application's finalizers are not robust to the
+presence of threads, see "Foreign Objects" in the manual for information
+on how to disable automatic finalization and instead run finalizers
+manually.
 
 ** Better locale support in Guile scripts
 
@@ -65,6 +80,12 @@ loop that collect its results in reverse order only to 
re-reverse them
 at the end, now you can just recurse without worrying about stack
 overflows.
 
+** Out-of-memory improvements
+
+Instead of aborting, failures to allocate memory will now raise an
+unwind-only `out-of-memory' exception, and cause the corresponding
+`catch' expression to run garbage collection in order to free up memory.
+
 * Performance improvements
 
 ** Faster programs via new virtual machine
@@ -95,9 +116,11 @@ as well.  See "Object File Format" in the manual, for full 
details.
 Guile's compiler now uses a Continuation-Passing Style (CPS)
 intermediate language, allowing it to reason easily about temporary
 values and control flow.  Examples of optimizations that this permits
-are optimal contification, dead code elimination, parallel moves with at
-most one temporary, and allocation of stack slots using precise liveness
-information.  For more, see "Continuation-Passing Style" in the manual.
+are optimal contification, optimal common subexpression elimination,
+dead code elimination, parallel moves with at most one temporary,
+allocation of stack slots using precise liveness information, and
+closure optimization.  For more, see "Continuation-Passing Style" in the
+manual.
 
 ** Faster interpreter
 
@@ -125,6 +148,12 @@ its string hash, and Thomas Wang's integer hash function 
for `hashq' and
 `hashv'.  These functions produce much better hash values across all
 available fixnum bits.
 
+** Optimized generic array facility
+
+Thanks to work by Daniel Llorens, the generic array facility is much
+faster now, as it is internally better able to dispatch on the type of
+the underlying backing store.
+
 * New interfaces
 
 ** New `cond-expand' feature: `guile-2.2'
@@ -180,10 +209,6 @@ For more on `SCM_HAS_TYP7', `SCM_HAS_TYP7S', 
`SCM_HAS_TYP16', see XXX.
 the old `SCM2PTR' and `PTR2SCM'.  Also, `SCM_UNPACK_POINTER' yields a
 void*.
 
-** `scm_c_weak_vector_ref', `scm_c_weak_vector_set_x'
-
-Weak vectors can now be accessed from C using these accessors.
-
 ** <standard-vtable>, standard-vtable-fields
 
 See "Structures" in the manual for more on these
@@ -340,15 +365,35 @@ of compiling to objcode and then calling `make-program', 
now the way to
 do it is to compile to `bytecode' and then call `load-thunk-from-memory'
 from `(system vm loader)'.
 
-** Remove weak pairs.
+** Weak pairs removed
 
 Weak pairs were not safe to access with `car' and `cdr', and so were
 removed.
 
-** Remove weak alist vectors.
+** Weak alist vectors removed
 
 Use weak hash tables instead.
 
+** Weak vectors may no longer be accessed via `vector-ref' et al
+
+Weak vectors may no longer be accessed with the vector interface.  This
+was a source of bugs in the 2.0 Guile implementation, and a limitation
+on using vectors as building blocks for other abstractions.  Vectors in
+Guile are now a concrete type; for an abstract interface, use the
+generic array facility (`array-ref' et al).
+
+** scm_t_array_implementation removed
+
+This interface was introduced in 2.0 but never documented.  It was a
+failed attempt to layer the array implementation that actually
+introduced too many layers, as it prevented the "vref" and "vset"
+members of scm_t_array_handle (called "ref" and "set" in 1.8, not
+present in 2.0) from specializing on array backing stores.
+
+Notably, the definition of scm_t_array_handle has now changed, to not
+include the (undocumented) "impl" member.  We are sorry for any
+inconvenience this may cause.
+
 * New deprecations
 
 ** SCM_WTA_DISPATCH_0, SCM_WTA_DISPATCH_1, SCM_WTA_DISPATCH_2, 
SCM_WTA_DISPATCH_N
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 5ca0bb5..ad1c4b3 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -58,6 +58,8 @@ index corresponds to MIN-LABEL, and so on."
     (define (label->idx label) (- label min-label))
     (define (idx->label idx) (+ idx min-label))
 
+    (synthesize-definition-effects! effects dfg min-label label-count)
+
     (let lp ((n 0))
       (when (< n label-count)
         (let ((in (make-bitvector label-count #f))
@@ -120,17 +122,12 @@ index corresponds to MIN-LABEL, and so on."
                         (unless (effects-commute? (vector-ref effects i) fx)
                           (bitvector-set! out i #f))
                         (lp (1+ i))))))))
-              ;; Unless this expression allocates a fresh object or
-              ;; changes the current fluid environment, mark expressions
-              ;; that match it as available for elimination.
-              (unless (causes-effects? fx (logior &fluid-environment
-                                                  &allocation))
-                (bitvector-set! out n #t))
+              (bitvector-set! out n #t)
               (lp (1+ n) first? (or changed? (not (= prev-count 
new-count)))))))
          (else
           (if (or first? changed?)
               (lp 0 #f #f)
-              avail-in)))))))
+              (values avail-in effects))))))))
 
 (define (compute-truthy-expressions dfg min-label label-count)
   "Compute a \"truth map\", indicating which expressions can be shown to
@@ -201,6 +198,8 @@ be that both true and false proofs are available."
               (lp 0 #f #f)
               boolv)))))))
 
+;; Returns a map of label-idx -> (var-idx ...) indicating the variables
+;; defined by a given labelled expression.
 (define (compute-defs dfg min-label label-count)
   (define (cont-defs k)
     (match (lookup-cont k dfg)
@@ -316,9 +315,8 @@ be that both true and false proofs are available."
     doms))
 
 (define (compute-equivalent-subexpressions fun dfg)
-  (define (compute min-label label-count min-var var-count)
-    (let ((avail (compute-available-expressions dfg min-label label-count))
-          (idoms (compute-idoms dfg min-label label-count))
+  (define (compute min-label label-count min-var var-count avail effects)
+    (let ((idoms (compute-idoms dfg min-label label-count))
           (defs (compute-defs dfg min-label label-count))
           (var-substs (make-vector var-count #f))
           (equiv-labels (make-vector label-count #f))
@@ -357,6 +355,41 @@ be that both true and false proofs are available."
           (($ $values args) #f)
           (($ $prompt escape? tag handler) #f)))
 
+      (define (add-auxiliary-definitions! label exp-key)
+        (let ((defs (vector-ref defs (label->idx label))))
+          (define (add-def! aux-key var)
+            (let ((equiv (hash-ref equiv-set aux-key '())))
+              (hash-set! equiv-set aux-key
+                         (acons label (list var) equiv))))
+          (match exp-key
+            (('primcall 'cons car cdr)
+             (match defs
+               ((pair)
+                (add-def! `(primcall car ,pair) car)
+                (add-def! `(primcall cdr ,pair) cdr))))
+            (('primcall 'set-car! pair car)
+             (add-def! `(primcall car ,pair) car))
+            (('primcall 'set-cdr! pair cdr)
+             (add-def! `(primcall cdr ,pair) cdr))
+            (('primcall (or 'make-vector 'make-vector/immediate) len fill)
+             (match defs
+               ((vec)
+                (add-def! `(primcall vector-length ,vec) len))))
+            (('primcall 'vector-set! vec idx val)
+             (add-def! `(primcall vector-ref ,vec ,idx) val))
+            (('primcall 'vector-set!/immediate vec idx val)
+             (add-def! `(primcall vector-ref/immediate ,vec ,idx) val))
+            (('primcall (or 'allocate-struct 'allocate-struct/immediate)
+                        vtable size)
+             (match defs
+               ((struct)
+                (add-def! `(primcall struct-vtable ,struct) vtable))))
+            (('primcall 'struct-set! struct n val)
+             (add-def! `(primcall struct-ref ,struct ,n) val))
+            (('primcall 'struct-set!/immediate struct n val)
+             (add-def! `(primcall struct-ref/immediate ,struct ,n) val))
+            (_ #t))))
+
       ;; The initial substs vector is the identity map.
       (let lp ((var min-var))
         (when (< (var->idx var) var-count)
@@ -373,15 +406,31 @@ be that both true and false proofs are available."
                (($ $continue k src exp)
                 (let* ((exp-key (compute-exp-key exp))
                        (equiv (hash-ref equiv-set exp-key '()))
-                       (avail (vector-ref avail (label->idx label))))
+                       (lidx (label->idx label))
+                       (avail (vector-ref avail lidx)))
+                  ;; If this expression defines auxiliary definitions,
+                  ;; as `cons' does for the results of `car' and `cdr',
+                  ;; define those.
+                  (add-auxiliary-definitions! label exp-key)
                   (let lp ((candidates equiv))
                     (match candidates
                       (()
                        ;; No matching expressions.  Add our expression
-                       ;; to the equivalence set, if appropriate.
-                       (when exp-key
-                         (hash-set! equiv-set exp-key (cons label equiv))))
-                      ((candidate . candidates)
+                       ;; to the equivalence set, if appropriate.  Note
+                       ;; that expressions that allocate a fresh object
+                       ;; or change the current fluid environment can't
+                       ;; be eliminated by CSE (though DCE might do it
+                       ;; if the value proves to be unused, in the
+                       ;; allocation case).
+                       (when (and exp-key
+                                  (not (causes-effects?
+                                        (vector-ref effects lidx)
+                                        (logior &fluid-environment
+                                                &allocation))))
+                         (hash-set! equiv-set exp-key
+                                    (acons label (vector-ref defs lidx)
+                                           equiv))))
+                      (((and head (candidate . vars)) . candidates)
                        (cond
                         ((not (bitvector-ref avail (label->idx candidate)))
                          ;; This expression isn't available here; try
@@ -389,25 +438,30 @@ be that both true and false proofs are available."
                          (lp candidates))
                         (else
                          ;; Yay, a match.  Mark expression as equivalent.
-                         (vector-set! equiv-labels (label->idx label)
-                                      candidate)
+                         (vector-set! equiv-labels lidx head)
                          ;; If we dominate the successor, mark vars
                          ;; for substitution.
                          (when (= label (vector-ref idoms (label->idx k)))
                            (for-each/2
                             (lambda (var subst-var)
                               (vector-set! var-substs (var->idx var) 
subst-var))
-                            (vector-ref defs (label->idx label))
-                            (vector-ref defs (label->idx candidate)))))))))))))
+                            (vector-ref defs lidx)
+                            vars)))))))))))
             (_ #f))
           (lp (1+ label))))
       (values (compute-dom-edges idoms min-label)
-              equiv-labels defs min-label var-substs min-var)))
+              equiv-labels min-label var-substs min-var)))
 
-  (call-with-values (lambda () (compute-label-and-var-ranges fun)) compute))
+  (call-with-values (lambda () (compute-label-and-var-ranges fun))
+    (lambda (min-label label-count min-var var-count)
+      (call-with-values
+          (lambda ()
+            (compute-available-expressions dfg min-label label-count))
+        (lambda (avail effects)
+          (compute min-label label-count min-var var-count avail effects))))))
 
 (define (apply-cse fun dfg
-                   doms equiv-labels defs min-label var-substs min-var boolv)
+                   doms equiv-labels min-label var-substs min-var boolv)
   (define (idx->label idx) (+ idx min-label))
   (define (label->idx label) (- label min-label))
   (define (idx->var idx) (+ idx min-var))
@@ -465,9 +519,9 @@ be that both true and false proofs are available."
         (_
          (cond
           ((vector-ref equiv-labels (label->idx label))
-           => (lambda (equiv)
-                (let* ((eidx (label->idx equiv))
-                       (vars (vector-ref defs eidx)))
+           => (match-lambda
+               ((equiv . vars)
+                (let* ((eidx (label->idx equiv)))
                   (rewrite-cps-term (lookup-cont k dfg)
                     (($ $kif kt kf)
                      ,(let* ((bool (vector-ref boolv (label->idx label)))
@@ -484,7 +538,7 @@ be that both true and false proofs are available."
                     ;; only $values, $call, or $callk can continue to
                     ;; $ktail.
                     (_
-                     ($continue k src ,(visit-exp exp)))))))
+                     ($continue k src ,(visit-exp exp))))))))
           (else
            (build-cps-term
              ($continue k src ,(visit-exp exp))))))))
@@ -522,8 +576,8 @@ be that both true and false proofs are available."
 
 (define (cse fun dfg)
   (call-with-values (lambda () (compute-equivalent-subexpressions fun dfg))
-    (lambda (doms equiv-labels defs min-label var-substs min-var)
-      (apply-cse fun dfg doms equiv-labels defs min-label var-substs min-var
+    (lambda (doms equiv-labels min-label var-substs min-var)
+      (apply-cse fun dfg doms equiv-labels min-label var-substs min-var
                  (compute-truthy-expressions dfg
                                              min-label (vector-length 
doms))))))
 
diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index 49b4088..fe6e8b3 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -45,6 +45,7 @@
   #:use-module (ice-9 match)
   #:export (expression-effects
             compute-effects
+            synthesize-definition-effects!
 
             &fluid
             &fluid-environment
@@ -205,12 +206,14 @@
 (define-inlinable (&causes a)
   (logand a (cause &all-effects)))
 
-(define (exclude-effects effects exclude)
+(define-inlinable (exclude-effects effects exclude)
   (logand effects (lognot (cause exclude))))
-(define (effect-free? effects)
+(define-inlinable (effect-free? effects)
   (zero? (&causes effects)))
-(define (constant? effects)
+(define-inlinable (constant? effects)
   (zero? effects))
+(define-inlinable (effects-clobber effects)
+  (ash (&causes effects) -1))
 
 (define-inlinable (depends-on-effects? x effects)
   (not (zero? (logand (&depends-on x) effects))))
@@ -289,7 +292,7 @@
   ((memq x y) (logior (cause &type-check) &car &cdr))
   ((memv x y) (logior (cause &type-check) &car &cdr))
   ((list? arg) &cdr)
-  ((length l) (logior (cause &type-check) &car &cdr)))
+  ((length l) (logior (cause &type-check) &cdr)))
 
 ;; Vectors.
 (define-primitive-effects
@@ -312,6 +315,8 @@
 (define-primitive-effects* dfg
   ((allocate-struct vtable nfields)
    (logior (cause &type-check) (cause &allocation)))
+  ((allocate-struct/immediate vtable nfields)
+   (logior (cause &type-check) (cause &allocation)))
   ((make-struct vtable ntail . args)
    (logior (cause &type-check) (cause &allocation)))
   ((make-struct/no-tail vtable . args)
@@ -492,3 +497,41 @@
            (($ $ktail) &no-effects)))
         (lp (1+ n))))
     effects))
+
+;; There is a way to abuse effects analysis in CSE to also do scalar
+;; replacement, effectively adding `car' and `cdr' expressions to `cons'
+;; expressions, and likewise with other constructors and setters.  This
+;; routine adds appropriate effects to `cons' and `set-car!' and the
+;; like.
+;;
+;; This doesn't affect CSE's ability to eliminate expressions, given
+;; that allocations aren't eliminated anyway, and the new effects will
+;; just cause the allocations not to commute with e.g. set-car!  which
+;; is what we want anyway.
+(define* (synthesize-definition-effects! effects dfg min-label #:optional
+                                         (label-count (vector-length effects)))
+  (define (label->idx label) (- label min-label))
+  (let lp ((label min-label))
+    (when (< label (+ min-label label-count))
+      (let* ((lidx (label->idx label))
+             (fx (vector-ref effects lidx)))
+        (define (add-deps! deps)
+          (vector-set! effects lidx (logior fx deps)))
+        (match (lookup-cont label dfg)
+          (($ $kargs _ _ term)
+           (match (find-expression term)
+             (($ $primcall 'cons)
+              (add-deps! (logior &car &cdr)))
+             (($ $primcall (or 'make-vector 'make-vector/immediate))
+              (add-deps! &vector))
+             (($ $primcall (or 'allocate-struct 'allocate-struct/immediate
+                               'make-struct/no-tail 'make-struct))
+              (add-deps! &struct))
+             (($ $primcall 'box)
+              (add-deps! &box))
+             (_
+              (add-deps! (effects-clobber
+                          (logior fx &car &cdr &vector &struct &box)))
+              #t)))
+          (_ #t))
+        (lp (1+ label))))))


hooks/post-receive
-- 
GNU Guile