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           (($ <toplevel-ref>)
 215            (logior &toplevel
 216                    (cause &type-check)))
 217           (($ <module-ref>)
 218            (logior &toplevel
 219                    (cause &type-check)))
 220           (($ <module-set> _ mod name public? exp)
 221            (logior (cause &toplevel)
 222                    (cause &type-check)
 223                    (compute-effects exp)))
 224           (($ <toplevel-define> _ name exp)
 225            (logior (cause &toplevel)
 226                    (compute-effects exp)))
 227           (($ <toplevel-set> _ name exp)
 228            (logior (cause &toplevel)
 229                    (compute-effects exp)))
 230           (($ <primitive-ref>)
 231            &no-effects)
 232           (($ <conditional> _ test consequent alternate)
 233            (let ((tfx (compute-effects test))
 234                  (cfx (compute-effects consequent))
 235                  (afx (compute-effects alternate)))
 236              (if (causes-effects? (logior tfx (logand afx cfx))
 237                                   &definite-bailout)
 238                  (logior tfx cfx afx)
 239                  (exclude-effects (logior tfx cfx afx)
 240                                   &definite-bailout))))
 241
 242           ;; Zero values.
 243           (($ <primcall> _ 'values ())
 244            (cause &zero-values))
 245
 246           ;; Effect-free primitives.
 247           (($ <primcall> _ (or 'values 'eq? 'eqv? 'equal?) args)
 248            (accumulate-effects args))
 249
 250           (($ <primcall> _ (or 'not 'pair? 'null? 'list? 'symbol?
 251                                'vector? 'struct? 'string? 'number?
 252                                'char?)
 253               (arg))
 254            (compute-effects arg))
 255
 256           ;; Primitives that allocate memory.
 257           (($ <primcall> _ 'cons (x y))
 258            (logior (compute-effects x) (compute-effects y)
 259                    &allocation))
 260
 261           (($ <primcall> _ (or 'list 'vector) args)
 262            (logior (accumulate-effects args) &allocation))
 263
 264           (($ <primcall> _ 'make-prompt-tag ())
 265            &allocation)
 266
 267           (($ <primcall> _ 'make-prompt-tag (arg))
 268            (logior (compute-effects arg) &allocation))
 269
 270           (($ <primcall> _ 'fluid-ref (fluid))
 271            (logior (compute-effects fluid)
 272                    (cause &type-check)
 273                    &fluid))
 274
 275           (($ <primcall> _ 'fluid-set! (fluid exp))
 276            (logior (compute-effects fluid)
 277                    (compute-effects exp)
 278                    (cause &type-check)
 279                    (cause &fluid)))
 280
 281           (($ <primcall> _ 'push-fluid (fluid val))
 282            (logior (compute-effects fluid)
 283                    (compute-effects val)
 284                    (cause &type-check)
 285                    (cause &fluid)))
 286
 287           (($ <primcall> _ 'pop-fluid ())
 288            (logior (cause &fluid)))
 289
 290           ;; Primitives that are normally effect-free, but which might
 291           ;; cause type checks, allocate memory, or access mutable
 292           ;; memory.  FIXME: expand, to be more precise.
 293           (($ <primcall> _ (and name (? effect-free-primitive?)) args)
 294            (logior (accumulate-effects args)
 295                    (cause &type-check)
 296                    (if (constructor-primitive? name)
 297                        (cause &allocation)
 298                        (if (accessor-primitive? name)
 299                            &mutable-data
 300                            &no-effects))))
 301
 302           ;; Lambda applications might throw wrong-number-of-args.
 303           (($ <call> _ ($ <lambda> _ _ body) args)
 304            (logior (accumulate-effects args)
 305                    (match body
 306                      (($ <lambda-case> _ req #f #f #f () syms body #f)
 307                       (logior (compute-effects body)
 308                               (if (= (length req) (length args))
 309                                   0
 310                                   (cause &type-check))))
 311                      (($ <lambda-case>)
 312                       (logior (compute-effects body)
 313                               (cause &type-check)))
 314                      (#f
 315                       ;; Calling a case-lambda with no clauses
 316                       ;; definitely causes bailout.
 317                       (logior (cause &definite-bailout)
 318                               (cause &possible-bailout))))))
 319
 320           ;; Bailout primitives.
 321           (($ <primcall> _ (? bailout-primitive? name) args)
 322            (logior (accumulate-effects args)
 323                    (cause &definite-bailout)
 324                    (cause &possible-bailout)))
 325
 326           ;; A call to a lexically bound procedure, perhaps labels
 327           ;; allocated.
 328           (($ <call> _ (and proc ($ <lexical-ref> _ _ sym)) args)
 329            (cond
 330             ((lookup sym)
 331              => (lambda (proc)
 332                   (compute-effects (make-call #f proc args))))
 333             (else
 334              (logior &all-effects-but-bailout
 335                      (cause &all-effects-but-bailout)))))
 336
 337           ;; A call to an unknown procedure can do anything.
 338           (($ <primcall> _ name args)
 339            (logior &all-effects-but-bailout
 340                    (cause &all-effects-but-bailout)))
 341           (($ <call> _ proc args)
 342            (logior &all-effects-but-bailout
 343                    (cause &all-effects-but-bailout)))
 344
 345           (($ <lambda> _ meta body)
 346            &no-effects)
 347           (($ <lambda-case> _ req opt rest kw inits gensyms body alt)
 348            (logior (exclude-effects (accumulate-effects inits)
 349                                     &definite-bailout)
 350                    (if (or-map assigned-lexical? gensyms)
 351                        (cause &allocation)
 352                        &no-effects)
 353                    (compute-effects body)
 354                    (if alt (compute-effects alt) &no-effects)))
 355
 356           (($ <seq> _ head tail)
 357            (logior
 358             ;; Returning zero values to a for-effect continuation is
 359             ;; not observable.
 360             (exclude-effects (compute-effects head)
 361                              (cause &zero-values))
 362             (compute-effects tail)))
 363
 364           (($ <prompt> _ tag body handler)
 365            (logior (compute-effects tag)
 366                    (compute-effects body)
 367                    (compute-effects handler)))
 368
 369           (($ <abort> _ tag args tail)
 370            (logior &all-effects-but-bailout
 371                    (cause &all-effects-but-bailout)))))
 372
 373       (compute-effects exp))
 374
 375     compute-effects))