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