module/language/tree-il/effects.scm

   1 ;;; Effects analysis on Tree-IL
   2
   3 ;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (language tree-il effects)
  20   #:use-module (language tree-il)
  21   #:use-module (language tree-il primitives)
  22   #:use-module (ice-9 match)
  23   #:export (make-effects-analyzer
  24             &mutable-lexical
  25             &toplevel
  26             &fluid
  27             &definite-bailout
  28             &possible-bailout
  29             &zero-values
  30             &allocation
  31             &mutable-data
  32             &type-check
  33             &all-effects
  34             effects-commute?
  35             exclude-effects
  36             effect-free?
  37             constant?
  38             depends-on-effects?
  39             causes-effects?))
  40
  41 ;;;
  42 ;;; Hey, it's some effects analysis!  If you invoke
  43 ;;; `make-effects-analyzer', you get a procedure that computes the set
  44 ;;; of effects that an expression depends on and causes.  This
  45 ;;; information is useful when writing algorithms that move code around,
  46 ;;; while preserving the semantics of an input program.
  47 ;;;
  48 ;;; The effects set is represented by a bitfield, as a fixnum.  The set
  49 ;;; of possible effects is modelled rather coarsely.  For example, a
  50 ;;; toplevel reference to FOO is modelled as depending on the &toplevel
  51 ;;; effect, and causing a &type-check effect.  If any intervening code
  52 ;;; sets any toplevel variable, that will block motion of FOO.
  53 ;;;
  54 ;;; For each effect, two bits are reserved: one to indicate that an
  55 ;;; expression depends on the effect, and the other to indicate that an
  56 ;;; expression causes the effect.
  57 ;;;
  58
  59 (define-syntax define-effects
  60   (lambda (x)
  61     (syntax-case x ()
  62       ((_ all name ...)
  63        (with-syntax (((n ...) (iota (length #'(name ...)))))
  64          #'(begin
  65              (define name (ash 1 (* n 2)))
  66              ...
  67              (define all (logior name ...))))))))
  68
  69 ;; Here we define the effects, indicating the meaning of the effect.
  70 ;;
  71 ;; Effects that are described in a "depends on" sense can also be used
  72 ;; in the "causes" sense.
  73 ;;
  74 ;; Effects that are described as causing an effect are not usually used
  75 ;; in a "depends-on" sense.  Although the "depends-on" sense is used
  76 ;; when checking for the existence of the "causes" effect, the effects
  77 ;; analyzer will not associate the "depends-on" sense of these effects
  78 ;; with any expression.
  79 ;;
  80 (define-effects &all-effects
  81   ;; Indicates that an expression depends on the value of a mutable
  82   ;; lexical variable.
  83   &mutable-lexical
  84
  85   ;; Indicates that an expression depends on the value of a toplevel
  86   ;; variable.
  87   &toplevel
  88
  89   ;; Indicates that an expression depends on the value of a fluid
  90   ;; variable.
  91   &fluid
  92
  93   ;; Indicates that an expression definitely causes a non-local,
  94   ;; non-resumable exit -- a bailout.  Only used in the "changes" sense.
  95   &definite-bailout
  96
  97   ;; Indicates that an expression may cause a bailout.
  98   &possible-bailout
  99
 100   ;; Indicates than an expression may return zero values -- a "causes"
 101   ;; effect.
 102   &zero-values
 103
 104   ;; Indicates that an expression may return a fresh object -- a
 105   ;; "causes" effect.
 106   &allocation
 107
 108   ;; Indicates that an expression depends on the value of a mutable data
 109   ;; structure.
 110   &mutable-data
 111
 112   ;; Indicates that an expression may cause a type check.  A type check,
 113   ;; for the purposes of this analysis, is the possibility of throwing
 114   ;; an exception the first time an expression is evaluated.  If the
 115   ;; expression did not cause an exception to be thrown, users can
 116   ;; assume that evaluating the expression again will not cause an
 117   ;; exception to be thrown.
 118   ;;
 119   ;; For example, (+ x y) might throw if X or Y are not numbers.  But if
 120   ;; it doesn't throw, it should be safe to elide a dominated, common
 121   ;; subexpression (+ x y).
 122   &type-check)
 123
 124 (define &no-effects 0)
 125
 126 ;; Definite bailout is an oddball effect.  Since it indicates that an
 127 ;; expression definitely causes bailout, it's not in the set of effects
 128 ;; of a call to an unknown procedure.  At the same time, it's also
 129 ;; special in that a definite bailout in a subexpression doesn't always
 130 ;; cause an outer expression to include &definite-bailout in its
 131 ;; effects.  For that reason we have to treat it specially.
 132 ;;
 133 (define &all-effects-but-bailout
 134   (logand &all-effects (lognot &definite-bailout)))
 135
 136 (define (cause effect)
 137   (ash effect 1))
 138
 139 (define (&depends-on a)
 140   (logand a &all-effects))
 141 (define (&causes a)
 142   (logand a (cause &all-effects)))
 143
 144 (define (exclude-effects effects exclude)
 145   (logand effects (lognot (cause exclude))))
 146 (define (effect-free? effects)
 147   (zero? (&causes effects)))
 148 (define (constant? effects)
 149   (zero? effects))
 150
 151 (define (depends-on-effects? x effects)
 152   (not (zero? (logand (&depends-on x) effects))))
 153 (define (causes-effects? x effects)
 154   (not (zero? (logand (&causes x) (cause effects)))))
 155
 156 (define (effects-commute? a b)
 157   (and (not (causes-effects? a (&depends-on b)))
 158        (not (causes-effects? b (&depends-on a)))))
 159
 160 (define (make-effects-analyzer assigned-lexical?)
 161   "Returns a procedure of type EXP -> EFFECTS that analyzes the effects
 162 of an expression."
 163
 164   (define compute-effects
 165     (let ((cache (make-hash-table)))
 166       (lambda (exp)
 167         (or (hashq-ref cache exp)
 168             (let ((effects (visit exp)))
 169               (hashq-set! cache exp effects)
 170               effects)))))
 171
 172   (define (accumulate-effects exps)
 173     (let lp ((exps exps) (out &no-effects))
 174       (if (null? exps)
 175           out
 176           (lp (cdr exps) (logior out (compute-effects (car exps)))))))
 177
 178   (define (visit exp)
 179     (match exp
 180       (($ <const>)
 181        &no-effects)
 182       (($ <void>)
 183        &no-effects)
 184       (($ <lexical-ref> _ _ gensym)
 185        (if (assigned-lexical? gensym)
 186            &mutable-lexical
 187            &no-effects))
 188       (($ <lexical-set> _ name gensym exp)
 189        (logior (cause &mutable-lexical)
 190                (compute-effects exp)))
 191       (($ <let> _ names gensyms vals body)
 192        (logior (if (or-map assigned-lexical? gensyms)
 193                    (cause &allocation)
 194                    &no-effects)
 195                (accumulate-effects vals)
 196                (compute-effects body)))
 197       (($ <letrec> _ in-order? names gensyms vals body)
 198        (logior (if (or-map assigned-lexical? gensyms)
 199                    (cause &allocation)
 200                    &no-effects)
 201                (accumulate-effects vals)
 202                (compute-effects body)))
 203       (($ <fix> _ names gensyms vals body)
 204        (logior (if (or-map assigned-lexical? gensyms)
 205                    (cause &allocation)
 206                    &no-effects)
 207                (accumulate-effects vals)
 208                (compute-effects body)))
 209       (($ <let-values> _ producer consumer)
 210        (logior (compute-effects producer)
 211                (compute-effects consumer)
 212                (cause &type-check)))
 213       (($ <dynwind> _ winder body unwinder)
 214        (logior (compute-effects winder)
 215                (compute-effects body)
 216                (compute-effects unwinder)))
 217       (($ <dynlet> _ fluids vals body)
 218        (logior (accumulate-effects fluids)
 219                (accumulate-effects vals)
 220                (cause &type-check)
 221                (cause &fluid)
 222                (compute-effects body)))
 223       (($ <dynref> _ fluid)
 224        (logior (compute-effects fluid)
 225                (cause &type-check)
 226                &fluid))
 227       (($ <dynset> _ fluid exp)
 228        (logior (compute-effects fluid)
 229                (compute-effects exp)
 230                (cause &type-check)
 231                (cause &fluid)))
 232       (($ <toplevel-ref>)
 233        (logior &toplevel
 234                (cause &type-check)))
 235       (($ <module-ref>)
 236        (logior &toplevel
 237                (cause &type-check)))
 238       (($ <module-set> _ mod name public? exp)
 239        (logior (cause &toplevel)
 240                (cause &type-check)
 241                (compute-effects exp)))
 242       (($ <toplevel-define> _ name exp)
 243        (logior (cause &toplevel)
 244                (compute-effects exp)))
 245       (($ <toplevel-set> _ name exp)
 246        (logior (cause &toplevel)
 247                (compute-effects exp)))
 248       (($ <primitive-ref>)
 249        &no-effects)
 250       (($ <conditional> _ test consequent alternate)
 251        (let ((tfx (compute-effects test))
 252              (cfx (compute-effects consequent))
 253              (afx (compute-effects alternate)))
 254          (if (causes-effects? (logior tfx (logand afx cfx))
 255                               &definite-bailout)
 256              (logior tfx cfx afx)
 257              (exclude-effects (logior tfx cfx afx)
 258                               &definite-bailout))))
 259
 260       ;; Zero values.
 261       (($ <application> _ ($ <primitive-ref> _ 'values) ())
 262        (cause &zero-values))
 263
 264       ;; Effect-free primitives.
 265       (($ <application> _
 266           ($ <primitive-ref> _ (and name
 267                                     (? effect+exception-free-primitive?)))
 268           args)
 269        (logior (accumulate-effects args)
 270                (if (constructor-primitive? name)
 271                    (cause &allocation)
 272                    &no-effects)))
 273       (($ <application> _
 274           ($ <primitive-ref> _ (and name
 275                                     (? effect-free-primitive?)))
 276           args)
 277        (logior (accumulate-effects args)
 278                (cause &type-check)
 279                (if (constructor-primitive? name)
 280                    (cause &allocation)
 281                    (if (accessor-primitive? name)
 282                        &mutable-data
 283                        &no-effects))))
 284
 285       ;; Lambda applications might throw wrong-number-of-args.
 286       (($ <application> _ ($ <lambda> _ _ body) args)
 287        (logior (compute-effects body)
 288                (accumulate-effects args)
 289                (cause &type-check)))
 290
 291       ;; Bailout primitives.
 292       (($ <application> src ($ <primitive-ref> _ (? bailout-primitive? name))
 293           args)
 294        (logior (accumulate-effects args)
 295                (cause &definite-bailout)
 296                (cause &possible-bailout)))
 297
 298       ;; A call to an unknown procedure can do anything.
 299       (($ <application> _ proc args)
 300        (logior &all-effects-but-bailout
 301                (cause &all-effects-but-bailout)))
 302
 303       (($ <lambda> _ meta body)
 304        &no-effects)
 305       (($ <lambda-case> _ req opt rest kw inits gensyms body alt)
 306        (logior (exclude-effects (accumulate-effects inits)
 307                                 &definite-bailout)
 308                (if (or-map assigned-lexical? gensyms)
 309                    (cause &allocation)
 310                    &no-effects)
 311                (compute-effects body)
 312                (if alt (compute-effects alt) &no-effects)))
 313
 314       (($ <sequence> _ exps)
 315        (let lp ((exps exps) (effects &no-effects))
 316          (match exps
 317            ((tail)
 318             (logior (compute-effects tail)
 319                     ;; Returning zero values to a for-effect continuation is
 320                     ;; not observable.
 321                     (exclude-effects effects (cause &zero-values))))
 322            ((head . tail)
 323             (lp tail (logior (compute-effects head) effects))))))
 324
 325       (($ <prompt> _ tag body handler)
 326        (logior (compute-effects tag)
 327                (compute-effects body)
 328                (compute-effects handler)))
 329
 330       (($ <abort> _ tag args tail)
 331        (logior &all-effects-but-bailout
 332                (cause &all-effects-but-bailout)))))
 333
 334   compute-effects)