module/language/cps/effects-analysis.scm

   1 ;;; Effects analysis on CPS
   2
   3 ;; Copyright (C) 2011, 2012, 2013, 2014, 2015 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 ;;; Commentary:
  20 ;;;
  21 ;;; A helper module to compute the set of effects caused by an
  22 ;;; expression.  This information is useful when writing algorithms that
  23 ;;; move code around, while preserving the semantics of an input
  24 ;;; program.
  25 ;;;
  26 ;;; The effects set is represented as an integer with three parts.  The
  27 ;;; low 4 bits indicate effects caused by an expression, as a bitfield.
  28 ;;; The next 4 bits indicate the kind of memory accessed by the
  29 ;;; expression, if it accesses mutable memory.  Finally the rest of the
  30 ;;; bits indicate the field in the object being accessed, if known, or
  31 ;;; -1 for unknown.
  32 ;;;
  33 ;;; In this way we embed a coarse type-based alias analysis in the
  34 ;;; effects analysis.  For example, a "car" call is modelled as causing
  35 ;;; a read to field 0 on a &pair, and causing a &type-check effect.  If
  36 ;;; any intervening code sets the car of any pair, that will block
  37 ;;; motion of the "car" call, because any write to field 0 of a pair is
  38 ;;; seen by effects analysis as being a write to field 0 of all pairs.
  39 ;;;
  40 ;;; Code:
  41
  42 (define-module (language cps effects-analysis)
  43   #:use-module (language cps)
  44   #:use-module (language cps dfg)
  45   #:use-module (ice-9 match)
  46   #:export (expression-effects
  47             compute-effects
  48             synthesize-definition-effects!
  49
  50             &allocation
  51             &type-check
  52             &read
  53             &write
  54
  55             &fluid
  56             &prompt
  57             &car
  58             &cdr
  59             &vector
  60             &box
  61             &module
  62             &struct
  63             &string
  64             &bytevector
  65
  66             &object
  67             &field
  68
  69             &allocate
  70             &read-object
  71             &read-field
  72             &write-object
  73             &write-field
  74
  75             &no-effects
  76             &all-effects
  77
  78             exclude-effects
  79             effect-free?
  80             constant?
  81             causes-effect?
  82             causes-all-effects?
  83             effect-clobbers?))
  84
  85 (define-syntax define-flags
  86   (lambda (x)
  87     (syntax-case x ()
  88       ((_ all shift name ...)
  89        (let ((count (length #'(name ...))))
  90          (with-syntax (((n ...) (iota count))
  91                        (count count))
  92            #'(begin
  93                (define-syntax name (identifier-syntax (ash 1 n)))
  94                ...
  95                (define-syntax all (identifier-syntax (1- (ash 1 count))))
  96                (define-syntax shift (identifier-syntax count)))))))))
  97
  98 (define-syntax define-enumeration
  99   (lambda (x)
 100     (define (count-bits n)
 101       (let lp ((out 1))
 102         (if (< n (ash 1 (1- out)))
 103             out
 104             (lp (1+ out)))))
 105     (syntax-case x ()
 106       ((_ mask shift name ...)
 107        (let* ((len (length #'(name ...)))
 108               (bits (count-bits len)))
 109          (with-syntax (((n ...) (iota len))
 110                        (bits bits))
 111            #'(begin
 112                (define-syntax name (identifier-syntax n))
 113                ...
 114                (define-syntax mask (identifier-syntax (1- (ash 1 bits))))
 115                (define-syntax shift (identifier-syntax bits)))))))))
 116
 117 (define-flags &all-effect-kinds &effect-kind-bits
 118   ;; Indicates that an expression may cause a type check.  A type check,
 119   ;; for the purposes of this analysis, is the possibility of throwing
 120   ;; an exception the first time an expression is evaluated.  If the
 121   ;; expression did not cause an exception to be thrown, users can
 122   ;; assume that evaluating the expression again will not cause an
 123   ;; exception to be thrown.
 124   ;;
 125   ;; For example, (+ x y) might throw if X or Y are not numbers.  But if
 126   ;; it doesn't throw, it should be safe to elide a dominated, common
 127   ;; subexpression (+ x y).
 128   &type-check
 129
 130   ;; Indicates that an expression may return a fresh object.  The kind
 131   ;; of object is indicated in the object kind field.
 132   &allocation
 133
 134   ;; Indicates that an expression may cause a read from memory.  The
 135   ;; kind of memory is given in the object kind field.  Some object
 136   ;; kinds have finer-grained fields; those are expressed in the "field"
 137   ;; part of the effects value.  -1 indicates "the whole object".
 138   &read
 139
 140   ;; Indicates that an expression may cause a write to memory.
 141   &write)
 142
 143 (define-enumeration &memory-kind-mask &memory-kind-bits
 144   ;; Indicates than an expression may access unknown kinds of memory.
 145   &unknown-memory-kinds
 146
 147   ;; Indicates that an expression depends on the value of a fluid
 148   ;; variable, or on the current fluid environment.
 149   &fluid
 150
 151   ;; Indicates that an expression depends on the current prompt
 152   ;; stack.
 153   &prompt
 154
 155   ;; Indicates that an expression depends on the value of the car or cdr
 156   ;; of a pair.
 157   &pair
 158
 159   ;; Indicates that an expression depends on the value of a vector
 160   ;; field.  The effect field indicates the specific field, or zero for
 161   ;; an unknown field.
 162   &vector
 163
 164   ;; Indicates that an expression depends on the value of a variable
 165   ;; cell.
 166   &box
 167
 168   ;; Indicates that an expression depends on the current module.
 169   &module
 170
 171   ;; Indicates that an expression depends on the value of a struct
 172   ;; field.  The effect field indicates the specific field, or zero for
 173   ;; an unknown field.
 174   &struct
 175
 176   ;; Indicates that an expression depends on the contents of a string.
 177   &string
 178
 179   ;; Indicates that an expression depends on the contents of a
 180   ;; bytevector.  We cannot be more precise, as bytevectors may alias
 181   ;; other bytevectors.
 182   &bytevector)
 183
 184 (define-inlinable (&field kind field)
 185   (ash (logior (ash field &memory-kind-bits) kind) &effect-kind-bits))
 186 (define-inlinable (&object kind)
 187   (&field kind -1))
 188
 189 (define-inlinable (&allocate kind)
 190   (logior &allocation (&object kind)))
 191 (define-inlinable (&read-field kind field)
 192   (logior &read (&field kind field)))
 193 (define-inlinable (&read-object kind)
 194   (logior &read (&object kind)))
 195 (define-inlinable (&write-field kind field)
 196   (logior &write (&field kind field)))
 197 (define-inlinable (&write-object kind)
 198   (logior &write (&object kind)))
 199
 200 (define-syntax &no-effects (identifier-syntax 0))
 201 (define-syntax &all-effects
 202   (identifier-syntax
 203    (logior &all-effect-kinds (&object &unknown-memory-kinds))))
 204
 205 (define-inlinable (constant? effects)
 206   (zero? effects))
 207
 208 (define-inlinable (causes-effect? x effects)
 209   (not (zero? (logand x effects))))
 210
 211 (define-inlinable (causes-all-effects? x)
 212   (eqv? x &all-effects))
 213
 214 (define (effect-clobbers? a b)
 215   "Return true if A clobbers B.  This is the case if A is a write, and B
 216 is or might be a read or a write to the same location as A."
 217   (define (locations-same?)
 218     (let ((a (ash a (- &effect-kind-bits)))
 219           (b (ash b (- &effect-kind-bits))))
 220       (or (eqv? &unknown-memory-kinds (logand a &memory-kind-mask))
 221           (eqv? &unknown-memory-kinds (logand b &memory-kind-mask))
 222           (and (eqv? (logand a &memory-kind-mask) (logand b &memory-kind-mask))
 223                ;; A negative field indicates "the whole object".
 224                ;; Non-negative fields indicate only part of the object.
 225                (or (< a 0) (< b 0) (= a b))))))
 226   (and (not (zero? (logand a &write)))
 227        (not (zero? (logand b (logior &read &write))))
 228        (locations-same?)))
 229
 230 (define (lookup-constant-index sym dfg)
 231   (call-with-values (lambda () (find-constant-value sym dfg))
 232     (lambda (has-const? val)
 233       (and has-const? (integer? val) (exact? val) (<= 0 val) val))))
 234
 235 (define-inlinable (indexed-field kind n dfg)
 236   (cond
 237    ((lookup-constant-index n dfg)
 238     => (lambda (idx)
 239          (&field kind idx)))
 240    (else (&object kind))))
 241
 242 (define *primitive-effects* (make-hash-table))
 243
 244 (define-syntax-rule (define-primitive-effects* dfg
 245                       ((name . args) effects ...)
 246                       ...)
 247   (begin
 248     (hashq-set! *primitive-effects* 'name
 249                 (case-lambda*
 250                  ((dfg . args) (logior effects ...))
 251                  (_ &all-effects)))
 252     ...))
 253
 254 (define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...)
 255   (define-primitive-effects* dfg ((name . args) effects ...) ...))
 256
 257 ;; Miscellaneous.
 258 (define-primitive-effects
 259   ((values . _)))
 260
 261 ;; Generic effect-free predicates.
 262 (define-primitive-effects
 263   ((eq? . _))
 264   ((eqv? . _))
 265   ((equal? . _))
 266   ((pair? arg))
 267   ((null? arg))
 268   ((nil? arg ))
 269   ((symbol? arg))
 270   ((variable? arg))
 271   ((vector? arg))
 272   ((struct? arg))
 273   ((string? arg))
 274   ((number? arg))
 275   ((char? arg))
 276   ((bytevector? arg))
 277   ((keyword? arg))
 278   ((bitvector? arg))
 279   ((procedure? arg))
 280   ((thunk? arg)))
 281
 282 ;; Fluids.
 283 (define-primitive-effects
 284   ((fluid-ref f)                   (&read-object &fluid)       &type-check)
 285   ((fluid-set! f v)                (&write-object &fluid)      &type-check)
 286   ((push-fluid f v)                (&write-object &fluid)      &type-check)
 287   ((pop-fluid)                     (&write-object &fluid)      &type-check))
 288
 289 ;; Prompts.
 290 (define-primitive-effects
 291   ((make-prompt-tag #:optional arg) (&allocate &unknown-memory-kinds)))
 292
 293 ;; Pairs.
 294 (define-primitive-effects
 295   ((cons a b)                      (&allocate &pair))
 296   ((list . _)                      (&allocate &pair))
 297   ((car x)                         (&read-field &pair 0)       &type-check)
 298   ((set-car! x y)                  (&write-field &pair 0)      &type-check)
 299   ((cdr x)                         (&read-field &pair 1)       &type-check)
 300   ((set-cdr! x y)                  (&write-field &pair 1)      &type-check)
 301   ((memq x y)                      (&read-object &pair)        &type-check)
 302   ((memv x y)                      (&read-object &pair)        &type-check)
 303   ((list? arg)                     (&read-field &pair 1))
 304   ((length l)                      (&read-field &pair 1)       &type-check))
 305
 306 ;; Variables.
 307 (define-primitive-effects
 308   ((box v)                         (&allocate &box))
 309   ((box-ref v)                     (&read-object &box)         &type-check)
 310   ((box-set! v x)                  (&write-object &box)        &type-check))
 311
 312 ;; Vectors.
 313 (define (vector-field n dfg)
 314   (indexed-field &vector n dfg))
 315 (define (read-vector-field n dfg)
 316   (logior &read (vector-field n dfg)))
 317 (define (write-vector-field n dfg)
 318   (logior &write (vector-field n dfg)))
 319 (define-primitive-effects* dfg
 320   ((vector . _)                    (&allocate &vector))
 321   ((make-vector n init)            (&allocate &vector)         &type-check)
 322   ((make-vector/immediate n init)  (&allocate &vector))
 323   ((vector-ref v n)                (read-vector-field n dfg)   &type-check)
 324   ((vector-ref/immediate v n)      (read-vector-field n dfg)   &type-check)
 325   ((vector-set! v n x)             (write-vector-field n dfg)  &type-check)
 326   ((vector-set!/immediate v n x)   (write-vector-field n dfg)  &type-check)
 327   ((vector-length v)                                           &type-check))
 328
 329 ;; Structs.
 330 (define (struct-field n dfg)
 331   (indexed-field &struct n dfg))
 332 (define (read-struct-field n dfg)
 333   (logior &read (struct-field n dfg)))
 334 (define (write-struct-field n dfg)
 335   (logior &write (struct-field n dfg)))
 336 (define-primitive-effects* dfg
 337   ((allocate-struct vt n)          (&allocate &struct)         &type-check)
 338   ((allocate-struct/immediate v n) (&allocate &struct)         &type-check)
 339   ((make-struct vt ntail . _)      (&allocate &struct)         &type-check)
 340   ((make-struct/no-tail vt . _)    (&allocate &struct)         &type-check)
 341   ((struct-ref s n)                (read-struct-field n dfg)   &type-check)
 342   ((struct-ref/immediate s n)      (read-struct-field n dfg)   &type-check)
 343   ((struct-set! s n x)             (write-struct-field n dfg)  &type-check)
 344   ((struct-set!/immediate s n x)   (write-struct-field n dfg)  &type-check)
 345   ((struct-vtable s)                                           &type-check))
 346
 347 ;; Strings.
 348 (define-primitive-effects
 349   ((string-ref s n)                (&read-object &string)      &type-check)
 350   ((string-set! s n c)             (&write-object &string)     &type-check)
 351   ((number->string _)              (&allocate &string)         &type-check)
 352   ((string->number _)              (&read-object &string)      &type-check)
 353   ((string-length s)                                           &type-check))
 354
 355 ;; Bytevectors.
 356 (define-primitive-effects
 357   ((bytevector-length _)                                       &type-check)
 358
 359   ((bv-u8-ref bv n)                (&read-object &bytevector)  &type-check)
 360   ((bv-s8-ref bv n)                (&read-object &bytevector)  &type-check)
 361   ((bv-u16-ref bv n)               (&read-object &bytevector)  &type-check)
 362   ((bv-s16-ref bv n)               (&read-object &bytevector)  &type-check)
 363   ((bv-u32-ref bv n)               (&read-object &bytevector)  &type-check)
 364   ((bv-s32-ref bv n)               (&read-object &bytevector)  &type-check)
 365   ((bv-u64-ref bv n)               (&read-object &bytevector)  &type-check)
 366   ((bv-s64-ref bv n)               (&read-object &bytevector)  &type-check)
 367   ((bv-f32-ref bv n)               (&read-object &bytevector)  &type-check)
 368   ((bv-f64-ref bv n)               (&read-object &bytevector)  &type-check)
 369
 370   ((bv-u8-set! bv n x)             (&write-object &bytevector) &type-check)
 371   ((bv-s8-set! bv n x)             (&write-object &bytevector) &type-check)
 372   ((bv-u16-set! bv n x)            (&write-object &bytevector) &type-check)
 373   ((bv-s16-set! bv n x)            (&write-object &bytevector) &type-check)
 374   ((bv-u32-set! bv n x)            (&write-object &bytevector) &type-check)
 375   ((bv-s32-set! bv n x)            (&write-object &bytevector) &type-check)
 376   ((bv-u64-set! bv n x)            (&write-object &bytevector) &type-check)
 377   ((bv-s64-set! bv n x)            (&write-object &bytevector) &type-check)
 378   ((bv-f32-set! bv n x)            (&write-object &bytevector) &type-check)
 379   ((bv-f64-set! bv n x)            (&write-object &bytevector) &type-check))
 380
 381 ;; Modules.
 382 (define-primitive-effects
 383   ((current-module)                (&read-object &module))
 384   ((cache-current-module! m scope) (&write-object &box))
 385   ((resolve name bound?)           (&read-object &module)      &type-check)
 386   ((cached-toplevel-box scope name bound?)                     &type-check)
 387   ((cached-module-box mod name public? bound?)                 &type-check)
 388   ((define! name val)              (&read-object &module) (&write-object &box)))
 389
 390 ;; Numbers.
 391 (define-primitive-effects
 392   ((= . _)                         &type-check)
 393   ((< . _)                         &type-check)
 394   ((> . _)                         &type-check)
 395   ((<= . _)                        &type-check)
 396   ((>= . _)                        &type-check)
 397   ((zero? . _)                     &type-check)
 398   ((add . _)                       &type-check)
 399   ((mul . _)                       &type-check)
 400   ((sub . _)                       &type-check)
 401   ((div . _)                       &type-check)
 402   ((sub1 . _)                      &type-check)
 403   ((add1 . _)                      &type-check)
 404   ((quo . _)                       &type-check)
 405   ((rem . _)                       &type-check)
 406   ((mod . _)                       &type-check)
 407   ((complex? _)                    &type-check)
 408   ((real? _)                       &type-check)
 409   ((rational? _)                   &type-check)
 410   ((inf? _)                        &type-check)
 411   ((nan? _)                        &type-check)
 412   ((integer? _)                    &type-check)
 413   ((exact? _)                      &type-check)
 414   ((inexact? _)                    &type-check)
 415   ((even? _)                       &type-check)
 416   ((odd? _)                        &type-check)
 417   ((ash n m)                       &type-check)
 418   ((logand . _)                    &type-check)
 419   ((logior . _)                    &type-check)
 420   ((logxor . _)                    &type-check)
 421   ((lognot . _)                    &type-check)
 422   ((logtest a b)                   &type-check)
 423   ((logbit? a b)                   &type-check)
 424   ((sqrt _)                        &type-check)
 425   ((abs _)                         &type-check))
 426
 427 ;; Characters.
 428 (define-primitive-effects
 429   ((char<? . _)                    &type-check)
 430   ((char<=? . _)                   &type-check)
 431   ((char>=? . _)                   &type-check)
 432   ((char>? . _)                    &type-check)
 433   ((integer->char _)               &type-check)
 434   ((char->integer _)               &type-check))
 435
 436 (define (primitive-effects dfg name args)
 437   (let ((proc (hashq-ref *primitive-effects* name)))
 438     (if proc
 439         (apply proc dfg args)
 440         &all-effects)))
 441
 442 (define (expression-effects exp dfg)
 443   (match exp
 444     ((or ($ $const) ($ $prim) ($ $values))
 445      &no-effects)
 446     (($ $fun)
 447      (&allocate &unknown-memory-kinds))
 448     (($ $prompt)
 449      (&write-object &prompt))
 450     ((or ($ $call) ($ $callk))
 451      &all-effects)
 452     (($ $branch k exp)
 453      (expression-effects exp dfg))
 454     (($ $primcall name args)
 455      (primitive-effects dfg name args))))
 456
 457 (define* (compute-effects dfg #:optional (min-label (dfg-min-label dfg))
 458                           (label-count (dfg-label-count dfg)))
 459   (let ((effects (make-vector label-count &no-effects)))
 460     (define (idx->label idx) (+ idx min-label))
 461     (let lp ((n 0))
 462       (when (< n label-count)
 463         (vector-set!
 464          effects
 465          n
 466          (match (lookup-cont (idx->label n) dfg)
 467            (($ $kargs names syms body)
 468             (expression-effects (find-expression body) dfg))
 469            (($ $kreceive arity kargs)
 470             (match arity
 471               (($ $arity _ () #f () #f) &type-check)
 472               (($ $arity () () _ () #f) (&allocate &pair))
 473               (($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check))))
 474            (($ $kfun) &type-check)
 475            (($ $kclause) &type-check)
 476            (($ $ktail) &no-effects)))
 477         (lp (1+ n))))
 478     effects))
 479
 480 ;; There is a way to abuse effects analysis in CSE to also do scalar
 481 ;; replacement, effectively adding `car' and `cdr' expressions to `cons'
 482 ;; expressions, and likewise with other constructors and setters.  This
 483 ;; routine adds appropriate effects to `cons' and `set-car!' and the
 484 ;; like.
 485 ;;
 486 ;; This doesn't affect CSE's ability to eliminate expressions, given
 487 ;; that allocations aren't eliminated anyway, and the new effects will
 488 ;; just cause the allocations not to commute with e.g. set-car!  which
 489 ;; is what we want anyway.
 490 (define* (synthesize-definition-effects! effects dfg min-label #:optional
 491                                          (label-count (vector-length effects)))
 492   (define (label->idx label) (- label min-label))
 493   (let lp ((label min-label))
 494     (when (< label (+ min-label label-count))
 495       (let* ((lidx (label->idx label))
 496              (fx (vector-ref effects lidx)))
 497         (unless (zero? (logand (logior &write &allocation) fx))
 498           (vector-set! effects lidx (logior (vector-ref effects lidx) &read)))
 499         (lp (1+ label))))))