module/language/cps/effects-analysis.scm

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