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