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 <[email protected]> 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 <[email protected]> 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
