module/language/tree-il/effects.scm

   1 ;;; Effects analysis on Tree-IL
   2
   3 ;; Copyright (C) 2011, 2012, 2013 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-syntax name (identifier-syntax (ash 1 (* n 2))))
  66              ...
  67              (define-syntax all (identifier-syntax (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-syntax &no-effects (identifier-syntax 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-syntax &all-effects-but-bailout
 134   (identifier-syntax
 135    (logand &all-effects (lognot &definite-bailout))))
 136
 137 (define-inlinable (cause effect)
 138   (ash effect 1))
 139
 140 (define-inlinable (&depends-on a)
 141   (logand a &all-effects))
 142 (define-inlinable (&causes a)
 143   (logand a (cause &all-effects)))
 144
 145 (define (exclude-effects effects exclude)
 146   (logand effects (lognot (cause exclude))))
 147 (define (effect-free? effects)
 148   (zero? (&causes effects)))
 149 (define (constant? effects)
 150   (zero? effects))
 151
 152 (define-inlinable (depends-on-effects? x effects)
 153   (not (zero? (logand (&depends-on x) effects))))
 154 (define-inlinable (causes-effects? x effects)
 155   (not (zero? (logand (&causes x) (cause effects)))))
 156
 157 (define-inlinable (effects-commute? a b)
 158   (and (not (causes-effects? a (&depends-on b)))
 159        (not (causes-effects? b (&depends-on a)))))
 160
 161 (define (make-effects-analyzer assigned-lexical?)
 162   "Returns a procedure of type EXP -> EFFECTS that analyzes the effects
 163 of an expression."
 164
 165   (let ((cache (make-hash-table)))
 166     (define* (compute-effects exp #:optional (lookup (lambda (x) #f)))
 167       (define (compute-effects exp)
 168         (or (hashq-ref cache exp)
 169             (let ((effects (visit exp)))
 170               (hashq-set! cache exp effects)
 171               effects)))
 172
 173       (define (accumulate-effects exps)
 174         (let lp ((exps exps) (out &no-effects))
 175           (if (null? exps)
 176               out
 177               (lp (cdr exps) (logior out (compute-effects (car exps)))))))
 178
 179       (define (visit exp)
 180         (match exp
 181           (($ <const>)
 182            &no-effects)
 183           (($ <void>)
 184            &no-effects)
 185           (($ <lexical-ref> _ _ gensym)
 186            (if (assigned-lexical? gensym)
 187                &mutable-lexical
 188                &no-effects))
 189           (($ <lexical-set> _ name gensym exp)
 190            (logior (cause &mutable-lexical)
 191                    (compute-effects exp)))
 192           (($ <let> _ names gensyms vals body)
 193            (logior (if (or-map assigned-lexical? gensyms)
 194                        (cause &allocation)
 195                        &no-effects)
 196                    (accumulate-effects vals)
 197                    (compute-effects body)))
 198           (($ <letrec> _ in-order? names gensyms vals body)
 199            (logior (if (or-map assigned-lexical? gensyms)
 200                        (cause &allocation)
 201                        &no-effects)
 202                    (accumulate-effects vals)
 203                    (compute-effects body)))
 204           (($ <fix> _ names gensyms vals body)
 205            (logior (if (or-map assigned-lexical? gensyms)
 206                        (cause &allocation)
 207                        &no-effects)
 208                    (accumulate-effects vals)
 209                    (compute-effects body)))
 210           (($ <let-values> _ producer consumer)
 211            (logior (compute-effects producer)
 212                    (compute-effects consumer)
 213                    (cause &type-check)))
 214           (($ <dynwind> _ winder pre body post unwinder)
 215            (logior (compute-effects winder)
 216                    (compute-effects pre)
 217                    (compute-effects body)
 218                    (compute-effects post)
 219                    (compute-effects unwinder)))
 220           (($ <dynlet> _ fluids vals body)
 221            (logior (accumulate-effects fluids)
 222                    (accumulate-effects vals)
 223                    (cause &type-check)
 224                    (cause &fluid)
 225                    (compute-effects body)))
 226           (($ <dynref> _ fluid)
 227            (logior (compute-effects fluid)
 228                    (cause &type-check)
 229                    &fluid))
 230           (($ <dynset> _ fluid exp)
 231            (logior (compute-effects fluid)
 232                    (compute-effects exp)
 233                    (cause &type-check)
 234                    (cause &fluid)))
 235           (($ <toplevel-ref>)
 236            (logior &toplevel
 237                    (cause &type-check)))
 238           (($ <module-ref>)
 239            (logior &toplevel
 240                    (cause &type-check)))
 241           (($ <module-set> _ mod name public? exp)
 242            (logior (cause &toplevel)
 243                    (cause &type-check)
 244                    (compute-effects exp)))
 245           (($ <toplevel-define> _ name exp)
 246            (logior (cause &toplevel)
 247                    (compute-effects exp)))
 248           (($ <toplevel-set> _ name exp)
 249            (logior (cause &toplevel)
 250                    (compute-effects exp)))
 251           (($ <primitive-ref>)
 252            &no-effects)
 253           (($ <conditional> _ test consequent alternate)
 254            (let ((tfx (compute-effects test))
 255                  (cfx (compute-effects consequent))
 256                  (afx (compute-effects alternate)))
 257              (if (causes-effects? (logior tfx (logand afx cfx))
 258                                   &definite-bailout)
 259                  (logior tfx cfx afx)
 260                  (exclude-effects (logior tfx cfx afx)
 261                                   &definite-bailout))))
 262
 263           ;; Zero values.
 264           (($ <primcall> _ 'values ())
 265            (cause &zero-values))
 266
 267           ;; Effect-free primitives.
 268           (($ <primcall> _ (or 'values 'eq? 'eqv? 'equal?) args)
 269            (accumulate-effects args))
 270
 271           (($ <primcall> _ (or 'not 'pair? 'null? 'list? 'symbol?
 272                                'vector? 'struct? 'string? 'number?
 273                                'char?)
 274               (arg))
 275            (compute-effects arg))
 276
 277           ;; Primitives that allocate memory.
 278           (($ <primcall> _ 'cons (x y))
 279            (logior (compute-effects x) (compute-effects y)
 280                    &allocation))
 281
 282           (($ <primcall> _ (or 'list 'vector) args)
 283            (logior (accumulate-effects args) &allocation))
 284
 285           (($ <primcall> _ 'make-prompt-tag ())
 286            &allocation)
 287
 288           (($ <primcall> _ 'make-prompt-tag (arg))
 289            (logior (compute-effects arg) &allocation))
 290
 291           ;; Primitives that are normally effect-free, but which might
 292           ;; cause type checks, allocate memory, or access mutable
 293           ;; memory.  FIXME: expand, to be more precise.
 294           (($ <primcall> _ (and name (? effect-free-primitive?)) args)
 295            (logior (accumulate-effects args)
 296                    (cause &type-check)
 297                    (if (constructor-primitive? name)
 298                        (cause &allocation)
 299                        (if (accessor-primitive? name)
 300                            &mutable-data
 301                            &no-effects))))
 302
 303           ;; Lambda applications might throw wrong-number-of-args.
 304           (($ <call> _ ($ <lambda> _ _ body) args)
 305            (logior (accumulate-effects args)
 306                    (match body
 307                      (($ <lambda-case> _ req #f #f #f () syms body #f)
 308                       (logior (compute-effects body)
 309                               (if (= (length req) (length args))
 310                                   0
 311                                   (cause &type-check))))
 312                      (($ <lambda-case>)
 313                       (logior (compute-effects body)
 314                               (cause &type-check)))
 315                      (#f
 316                       ;; Calling a case-lambda with no clauses
 317                       ;; definitely causes bailout.
 318                       (logior (cause &definite-bailout)
 319                               (cause &possible-bailout))))))
 320
 321           ;; Bailout primitives.
 322           (($ <primcall> _ (? bailout-primitive? name) args)
 323            (logior (accumulate-effects args)
 324                    (cause &definite-bailout)
 325                    (cause &possible-bailout)))
 326
 327           ;; A call to a lexically bound procedure, perhaps labels
 328           ;; allocated.
 329           (($ <call> _ (and proc ($ <lexical-ref> _ _ sym)) args)
 330            (cond
 331             ((lookup sym)
 332              => (lambda (proc)
 333                   (compute-effects (make-call #f proc args))))
 334             (else
 335              (logior &all-effects-but-bailout
 336                      (cause &all-effects-but-bailout)))))
 337
 338           ;; A call to an unknown procedure can do anything.
 339           (($ <primcall> _ name args)
 340            (logior &all-effects-but-bailout
 341                    (cause &all-effects-but-bailout)))
 342           (($ <call> _ proc args)
 343            (logior &all-effects-but-bailout
 344                    (cause &all-effects-but-bailout)))
 345
 346           (($ <lambda> _ meta body)
 347            &no-effects)
 348           (($ <lambda-case> _ req opt rest kw inits gensyms body alt)
 349            (logior (exclude-effects (accumulate-effects inits)
 350                                     &definite-bailout)
 351                    (if (or-map assigned-lexical? gensyms)
 352                        (cause &allocation)
 353                        &no-effects)
 354                    (compute-effects body)
 355                    (if alt (compute-effects alt) &no-effects)))
 356
 357           (($ <seq> _ head tail)
 358            (logior
 359             ;; Returning zero values to a for-effect continuation is
 360             ;; not observable.
 361             (exclude-effects (compute-effects head)
 362                              (cause &zero-values))
 363             (compute-effects tail)))
 364
 365           (($ <prompt> _ tag body handler)
 366            (logior (compute-effects tag)
 367                    (compute-effects body)
 368                    (compute-effects handler)))
 369
 370           (($ <abort> _ tag args tail)
 371            (logior &all-effects-but-bailout
 372                    (cause &all-effects-but-bailout)))))
 373
 374       (compute-effects exp))
 375
 376     compute-effects))