[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-385-g863dd87
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-385-g863dd87 |
|
Date: |
Sun, 10 Nov 2013 11:08:32 +0000 |
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=863dd873628a971176556a1da1bf2ab3f0ff5e55
The branch, master has been updated
via 863dd873628a971176556a1da1bf2ab3f0ff5e55 (commit)
via a2972c195dc6643dd6e1d518dc3a3014ed51d981 (commit)
from 056110754ead55733879b0c8a5c0d773f576d5c6 (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 863dd873628a971176556a1da1bf2ab3f0ff5e55
Author: Andy Wingo <address@hidden>
Date: Sun Nov 10 12:05:35 2013 +0100
Effects analysis distinguishes between struct fields
* module/language/tree-il/effects.scm (compile-time-cond):
(define-effects): Make the effects analysis more precise,
distinguishing between different kinds of mutable data. On 64-bit
systems we take advantage of the additional bits to be even more
precise.
(make-effects-analyzer): Inline handlers for all "accessor" primitives
and their corresponding mutators.
* module/language/tree-il/peval.scm (peval): Reflow to remove use of the
"accessor-primitive?" predicate.
* module/language/tree-il/primitives.scm (accessor-primitive?): Remove.
commit a2972c195dc6643dd6e1d518dc3a3014ed51d981
Author: Andy Wingo <address@hidden>
Date: Sun Nov 10 10:13:37 2013 +0100
Effects analysis sees match-error, throw-bad-structs as bailouts
* module/language/tree-il/effects.scm (make-effects-analyzer): Allow
module-ref calls to be treated as bailouts, if the procedure has the
"definite-bailout?" property. Perhaps this should be renamed.
* module/ice-9/match.upstream.scm (match-error):
* module/srfi/srfi-9.scm (throw-bad-struct): Give these procedures the
definite-bailout? property.
-----------------------------------------------------------------------
Summary of changes:
module/ice-9/match.upstream.scm | 1 +
module/language/tree-il/effects.scm | 306 +++++++++++++++++++++++++++-----
module/language/tree-il/peval.scm | 28 +--
module/language/tree-il/primitives.scm | 7 +-
module/srfi/srfi-9.scm | 1 +
5 files changed, 272 insertions(+), 71 deletions(-)
diff --git a/module/ice-9/match.upstream.scm b/module/ice-9/match.upstream.scm
index e32ba85..3d66555 100644
--- a/module/ice-9/match.upstream.scm
+++ b/module/ice-9/match.upstream.scm
@@ -281,6 +281,7 @@
;; expressions respectively.
(define (match-error v)
+ #((definite-bailout? . #t))
(error 'match "no matching pattern" v))
(define-syntax match-next
diff --git a/module/language/tree-il/effects.scm
b/module/language/tree-il/effects.scm
index 6302662..68bb8a8 100644
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -28,7 +28,6 @@
&possible-bailout
&zero-values
&allocation
- &mutable-data
&type-check
&all-effects
effects-commute?
@@ -55,6 +54,10 @@
;;; expression depends on the effect, and the other to indicate that an
;;; expression causes the effect.
;;;
+;;; Since we have more bits in a fixnum on 64-bit systems, we can be
+;;; more precise without losing efficiency. On a 32-bit system, some of
+;;; the more precise effects map to fewer bits.
+;;;
(define-syntax define-effects
(lambda (x)
@@ -66,6 +69,16 @@
...
(define-syntax all (identifier-syntax (logior name ...)))))))))
+(define-syntax compile-time-cond
+ (lambda (x)
+ (syntax-case x (else)
+ ((_ (else body ...))
+ #'(begin body ...))
+ ((_ (exp body ...) clause ...)
+ (if (eval (syntax->datum #'exp) (current-module))
+ #'(begin body ...)
+ #'(compile-time-cond clause ...))))))
+
;; Here we define the effects, indicating the meaning of the effect.
;;
;; Effects that are described in a "depends on" sense can also be used
@@ -77,49 +90,109 @@
;; analyzer will not associate the "depends-on" sense of these effects
;; with any expression.
;;
-(define-effects &all-effects
- ;; Indicates that an expression depends on the value of a mutable
- ;; lexical variable.
- &mutable-lexical
-
- ;; Indicates that an expression depends on the value of a toplevel
- ;; variable.
- &toplevel
-
- ;; Indicates that an expression depends on the value of a fluid
- ;; variable.
- &fluid
-
- ;; Indicates that an expression definitely causes a non-local,
- ;; non-resumable exit -- a bailout. Only used in the "changes" sense.
- &definite-bailout
-
- ;; Indicates that an expression may cause a bailout.
- &possible-bailout
-
- ;; Indicates than an expression may return zero values -- a "causes"
- ;; effect.
- &zero-values
-
- ;; Indicates that an expression may return a fresh object -- a
- ;; "causes" effect.
- &allocation
-
- ;; Indicates that an expression depends on the value of a mutable data
- ;; structure.
- &mutable-data
-
- ;; Indicates that an expression may cause a type check. A type check,
- ;; for the purposes of this analysis, is the possibility of throwing
- ;; an exception the first time an expression is evaluated. If the
- ;; expression did not cause an exception to be thrown, users can
- ;; assume that evaluating the expression again will not cause an
- ;; exception to be thrown.
- ;;
- ;; For example, (+ x y) might throw if X or Y are not numbers. But if
- ;; it doesn't throw, it should be safe to elide a dominated, common
- ;; subexpression (+ x y).
- &type-check)
+(compile-time-cond
+ ((>= (logcount most-positive-fixnum) 60)
+ (define-effects &all-effects
+ ;; Indicates that an expression depends on the value of a mutable
+ ;; lexical variable.
+ &mutable-lexical
+
+ ;; Indicates that an expression depends on the value of a toplevel
+ ;; variable.
+ &toplevel
+
+ ;; Indicates that an expression depends on the value of a fluid
+ ;; variable.
+ &fluid
+
+ ;; Indicates that an expression definitely causes a non-local,
+ ;; non-resumable exit -- a bailout. Only used in the "changes" sense.
+ &definite-bailout
+
+ ;; Indicates that an expression may cause a bailout.
+ &possible-bailout
+
+ ;; Indicates than an expression may return zero values -- a "causes"
+ ;; effect.
+ &zero-values
+
+ ;; Indicates that an expression may return a fresh object -- a
+ ;; "causes" effect.
+ &allocation
+
+ ;; Indicates that an expression depends on the value of the car of a
+ ;; pair.
+ &car
+
+ ;; Indicates that an expression depends on the value of the cdr of a
+ ;; pair.
+ &cdr
+
+ ;; Indicates that an expression depends on the value of a vector
+ ;; field. We cannot be more precise, as vectors may alias other
+ ;; vectors.
+ &vector
+
+ ;; Indicates that an expression depends on the value of a variable
+ ;; cell.
+ &variable
+
+ ;; Indicates that an expression depends on the value of a particular
+ ;; struct field.
+ &struct-0 &struct-1 &struct-2 &struct-3 &struct-4 &struct-5 &struct-6+
+
+ ;; Indicates that an expression depends on the contents of a string.
+ &string
+
+ ;; Indicates that an expression depends on the contents of a
+ ;; bytevector. We cannot be more precise, as bytevectors may alias
+ ;; other bytevectors.
+ &bytevector
+
+ ;; Indicates that an expression may cause a type check. A type check,
+ ;; for the purposes of this analysis, is the possibility of throwing
+ ;; an exception the first time an expression is evaluated. If the
+ ;; expression did not cause an exception to be thrown, users can
+ ;; assume that evaluating the expression again will not cause an
+ ;; exception to be thrown.
+ ;;
+ ;; For example, (+ x y) might throw if X or Y are not numbers. But if
+ ;; it doesn't throw, it should be safe to elide a dominated, common
+ ;; subexpression (+ x y).
+ &type-check)
+
+ ;; Indicates that an expression depends on the contents of an unknown
+ ;; struct field.
+ (define-syntax &struct
+ (identifier-syntax
+ (logior &struct-1 &struct-2 &struct-3 &struct-4 &struct-5 &struct-6+))))
+
+ (else
+ ;; For systems with smaller fixnums, be less precise regarding struct
+ ;; fields.
+ (define-effects &all-effects
+ &mutable-lexical
+ &toplevel
+ &fluid
+ &definite-bailout
+ &possible-bailout
+ &zero-values
+ &allocation
+ &car
+ &cdr
+ &vector
+ &variable
+ &struct
+ &string
+ &bytevector
+ &type-check)
+ (define-syntax &struct-0 (identifier-syntax &struct))
+ (define-syntax &struct-1 (identifier-syntax &struct))
+ (define-syntax &struct-2 (identifier-syntax &struct))
+ (define-syntax &struct-3 (identifier-syntax &struct))
+ (define-syntax &struct-4 (identifier-syntax &struct))
+ (define-syntax &struct-5 (identifier-syntax &struct))
+ (define-syntax &struct-6+ (identifier-syntax &struct))))
(define-syntax &no-effects (identifier-syntax 0))
@@ -287,17 +360,136 @@ of an expression."
(($ <primcall> _ 'pop-fluid ())
(logior (cause &fluid)))
+ (($ <primcall> _ 'car (x))
+ (logior (compute-effects x)
+ (cause &type-check)
+ &car))
+ (($ <primcall> _ 'set-car! (x y))
+ (logior (compute-effects x)
+ (compute-effects y)
+ (cause &type-check)
+ (cause &car)))
+
+ (($ <primcall> _ 'cdr (x))
+ (logior (compute-effects x)
+ (cause &type-check)
+ &cdr))
+ (($ <primcall> _ 'set-cdr! (x y))
+ (logior (compute-effects x)
+ (compute-effects y)
+ (cause &type-check)
+ (cause &cdr)))
+
+ (($ <primcall> _ (or 'memq 'memv) (x y))
+ (logior (compute-effects x)
+ (compute-effects y)
+ (cause &type-check)
+ &car &cdr))
+
+ (($ <primcall> _ 'vector-ref (v n))
+ (logior (compute-effects v)
+ (compute-effects n)
+ (cause &type-check)
+ &vector))
+ (($ <primcall> _ 'vector-set! (v n x))
+ (logior (compute-effects v)
+ (compute-effects n)
+ (compute-effects x)
+ (cause &type-check)
+ (cause &vector)))
+
+ (($ <primcall> _ 'variable-ref (v))
+ (logior (compute-effects v)
+ (cause &type-check)
+ &variable))
+ (($ <primcall> _ 'variable-set! (v x))
+ (logior (compute-effects v)
+ (compute-effects x)
+ (cause &type-check)
+ (cause &variable)))
+
+ (($ <primcall> _ 'struct-ref (s n))
+ (logior (compute-effects s)
+ (compute-effects n)
+ (cause &type-check)
+ (match n
+ (($ <const> _ 0) &struct-0)
+ (($ <const> _ 1) &struct-1)
+ (($ <const> _ 2) &struct-2)
+ (($ <const> _ 3) &struct-3)
+ (($ <const> _ 4) &struct-4)
+ (($ <const> _ 5) &struct-5)
+ (($ <const> _ _) &struct-6+)
+ (_ &struct))))
+ (($ <primcall> _ 'struct-set! (s n x))
+ (logior (compute-effects s)
+ (compute-effects n)
+ (compute-effects x)
+ (cause &type-check)
+ (match n
+ (($ <const> _ 0) (cause &struct-0))
+ (($ <const> _ 1) (cause &struct-1))
+ (($ <const> _ 2) (cause &struct-2))
+ (($ <const> _ 3) (cause &struct-3))
+ (($ <const> _ 4) (cause &struct-4))
+ (($ <const> _ 5) (cause &struct-5))
+ (($ <const> _ _) (cause &struct-6+))
+ (_ (cause &struct)))))
+
+ (($ <primcall> _ 'string-ref (s n))
+ (logior (compute-effects s)
+ (compute-effects n)
+ (cause &type-check)
+ &string))
+ (($ <primcall> _ 'string-set! (s n c))
+ (logior (compute-effects s)
+ (compute-effects n)
+ (compute-effects c)
+ (cause &type-check)
+ (cause &string)))
+
+ (($ <primcall> _
+ (or 'bytevector-u8-ref 'bytevector-s8-ref
+ 'bytevector-u16-ref 'bytevector-u16-native-ref
+ 'bytevector-s16-ref 'bytevector-s16-native-ref
+ 'bytevector-u32-ref 'bytevector-u32-native-ref
+ 'bytevector-s32-ref 'bytevector-s32-native-ref
+ 'bytevector-u64-ref 'bytevector-u64-native-ref
+ 'bytevector-s64-ref 'bytevector-s64-native-ref
+ 'bytevector-ieee-single-ref
'bytevector-ieee-single-native-ref
+ 'bytevector-ieee-double-ref
'bytevector-ieee-double-native-ref)
+ (bv n))
+ (logior (compute-effects bv)
+ (compute-effects n)
+ (cause &type-check)
+ &bytevector))
+ (($ <primcall> _
+ (or 'bytevector-u8-set! 'bytevector-s8-set!
+ 'bytevector-u16-set! 'bytevector-u16-native-set!
+ 'bytevector-s16-set! 'bytevector-s16-native-set!
+ 'bytevector-u32-set! 'bytevector-u32-native-set!
+ 'bytevector-s32-set! 'bytevector-s32-native-set!
+ 'bytevector-u64-set! 'bytevector-u64-native-set!
+ 'bytevector-s64-set! 'bytevector-s64-native-set!
+ 'bytevector-ieee-single-set!
'bytevector-ieee-single-native-set!
+ 'bytevector-ieee-double-set!
'bytevector-ieee-double-native-set!)
+ (bv n x))
+ (logior (compute-effects bv)
+ (compute-effects n)
+ (compute-effects x)
+ (cause &type-check)
+ (cause &bytevector)))
+
;; Primitives that are normally effect-free, but which might
- ;; cause type checks, allocate memory, or access mutable
- ;; memory. FIXME: expand, to be more precise.
+ ;; cause type checks or allocate memory. Nota bene,
+ ;; primitives that access mutable memory should be given their
+ ;; own inline cases above!
(($ <primcall> _ (and name (? effect-free-primitive?)) args)
(logior (accumulate-effects args)
(cause &type-check)
(if (constructor-primitive? name)
(cause &allocation)
- (if (accessor-primitive? name)
- &mutable-data
- &no-effects))))
+ &no-effects)))
;; Lambda applications might throw wrong-number-of-args.
(($ <call> _ ($ <lambda> _ _ body) args)
@@ -322,6 +514,22 @@ of an expression."
(logior (accumulate-effects args)
(cause &definite-bailout)
(cause &possible-bailout)))
+ (($ <call> _
+ (and proc
+ ($ <module-ref> _ mod name public?)
+ (? (lambda (_)
+ (false-if-exception
+ (procedure-property
+ (module-ref (if public?
+ (resolve-interface mod)
+ (resolve-module mod))
+ name)
+ 'definite-bailout?)))))
+ args)
+ (logior (compute-effects proc)
+ (accumulate-effects args)
+ (cause &definite-bailout)
+ (cause &possible-bailout)))
;; A call to a lexically bound procedure, perhaps labels
;; allocated.
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index 676ac89..8859dd4 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1265,7 +1265,7 @@ top-level bindings from ENV and return the resulting
expression."
(_
(make-primcall src 'thunk? (list proc)))))))))
- (($ <primcall> src (? accessor-primitive? name) args)
+ (($ <primcall> src name args)
(match (cons name (map for-value args))
;; FIXME: these for-tail recursions could take place outside
;; an effort counter.
@@ -1324,25 +1324,15 @@ top-level bindings from ENV and return the resulting
expression."
(for-tail (make-seq src k (make-const #f #f))))
(else
(make-primcall src name (list k (make-const #f elts))))))))
- ((name . args)
- (fold-constants src name args ctx))))
-
- (($ <primcall> src (? equality-primitive? name) (a b))
- (let ((val-a (for-value a))
- (val-b (for-value b)))
- (log 'equality-primitive name val-a val-b)
- (cond ((and (lexical-ref? val-a) (lexical-ref? val-b)
- (eq? (lexical-ref-gensym val-a)
- (lexical-ref-gensym val-b)))
- (for-tail (make-const #f #t)))
- (else
- (fold-constants src name (list val-a val-b) ctx)))))
-
- (($ <primcall> src (? effect-free-primitive? name) args)
- (fold-constants src name (map for-value args) ctx))
+ (((? equality-primitive?)
+ ($ <lexical-ref> _ _ sym) ($ <lexical-ref> _ _ sym))
+ (for-tail (make-const #f #t)))
- (($ <primcall> src name args)
- (make-primcall src name (map for-value args)))
+ (((? effect-free-primitive?) . args)
+ (fold-constants src name args ctx))
+
+ ((name . args)
+ (make-primcall src name args))))
(($ <call> src orig-proc orig-args)
;; todo: augment the global env with specialized functions
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index 5e4f388..0904573 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -29,7 +29,7 @@
#:export (resolve-primitives add-interesting-primitive!
expand-primitives
effect-free-primitive? effect+exception-free-primitive?
- constructor-primitive? accessor-primitive?
+ constructor-primitive?
singly-valued-primitive? equality-primitive?
bailout-primitive?
negate-primitive))
@@ -139,6 +139,9 @@
(define *primitive-accessors*
;; Primitives that are pure, but whose result depends on the mutable
;; memory pointed to by their operands.
+ ;;
+ ;; Note: if you add an accessor here, be sure to add a corresponding
+ ;; case in (language tree-il effects)!
'(vector-ref
car cdr
memq memv
@@ -242,8 +245,6 @@
(define (constructor-primitive? prim)
(memq prim *primitive-constructors*))
-(define (accessor-primitive? prim)
- (memq prim *primitive-accessors*))
(define (effect-free-primitive? prim)
(hashq-ref *effect-free-primitive-table* prim))
(define (effect+exception-free-primitive? prim)
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index 7275eaf..355362a 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -144,6 +144,7 @@
(display ">" p))
(define (throw-bad-struct s who)
+ #((definite-bailout? . #t))
(throw 'wrong-type-arg who
"Wrong type argument: ~S" (list s)
(list s)))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-385-g863dd87,
Andy Wingo <=