diff options
Diffstat (limited to 'module/language/cps/effects-analysis.scm')
-rw-r--r-- | module/language/cps/effects-analysis.scm | 621 |
1 files changed, 621 insertions, 0 deletions
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm new file mode 100644 index 000000000..250aec78a --- /dev/null +++ b/module/language/cps/effects-analysis.scm @@ -0,0 +1,621 @@ +;;; Effects analysis on CPS + +;; Copyright (C) 2011-2015, 2017, 2018 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; A helper module to compute the set of effects caused by an +;;; expression. This information is useful when writing algorithms that +;;; move code around, while preserving the semantics of an input +;;; program. +;;; +;;; The effects set is represented as an integer with three parts. The +;;; low 4 bits indicate effects caused by an expression, as a bitfield. +;;; The next 4 bits indicate the kind of memory accessed by the +;;; expression, if it accesses mutable memory. Finally the rest of the +;;; bits indicate the field in the object being accessed, if known, or +;;; -1 for unknown. +;;; +;;; In this way we embed a coarse type-based alias analysis in the +;;; effects analysis. For example, a "car" call is modelled as causing +;;; a read to field 0 on a &pair, and causing a &type-check effect. If +;;; any intervening code sets the car of any pair, that will block +;;; motion of the "car" call, because any write to field 0 of a pair is +;;; seen by effects analysis as being a write to field 0 of all pairs. +;;; +;;; Code: + +(define-module (language cps effects-analysis) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intset) + #:use-module (language cps intmap) + #:use-module (ice-9 match) + #:export (expression-effects + compute-effects + synthesize-definition-effects + + &allocation + &type-check + &read + &write + + &fluid + &prompt + &vector + &box + &module + &struct + &string + &thread + &bytevector + &closure + + &object + &field + + &allocate + &read-object + &read-field + &write-object + &write-field + + &no-effects + &all-effects + + causes-effect? + causes-all-effects? + effect-clobbers? + compute-clobber-map)) + +(define-syntax define-flags + (lambda (x) + (syntax-case x () + ((_ all shift name ...) + (let ((count (length #'(name ...)))) + (with-syntax (((n ...) (iota count)) + (count count)) + #'(begin + (define-syntax name (identifier-syntax (ash 1 n))) + ... + (define-syntax all (identifier-syntax (1- (ash 1 count)))) + (define-syntax shift (identifier-syntax count))))))))) + +(define-syntax define-enumeration + (lambda (x) + (define (count-bits n) + (let lp ((out 1)) + (if (< n (ash 1 (1- out))) + out + (lp (1+ out))))) + (syntax-case x () + ((_ mask shift name ...) + (let* ((len (length #'(name ...))) + (bits (count-bits len))) + (with-syntax (((n ...) (iota len)) + (bits bits)) + #'(begin + (define-syntax name (identifier-syntax n)) + ... + (define-syntax mask (identifier-syntax (1- (ash 1 bits)))) + (define-syntax shift (identifier-syntax bits))))))))) + +(define-flags &all-effect-kinds &effect-kind-bits + ;; Indicates that an expression may cause a type check. A type check, + ;; for the purposes of this analysis, is the possibility of throwing + ;; an exception the first time an expression is evaluated. If the + ;; expression did not cause an exception to be thrown, users can + ;; assume that evaluating the expression again will not cause an + ;; exception to be thrown. + ;; + ;; For example, (+ x y) might throw if X or Y are not numbers. But if + ;; it doesn't throw, it should be safe to elide a dominated, common + ;; subexpression (+ x y). + &type-check + + ;; Indicates that an expression may return a fresh object. The kind + ;; of object is indicated in the object kind field. + &allocation + + ;; Indicates that an expression may cause a read from memory. The + ;; kind of memory is given in the object kind field. Some object + ;; kinds have finer-grained fields; those are expressed in the "field" + ;; part of the effects value. -1 indicates "the whole object". + &read + + ;; Indicates that an expression may cause a write to memory. + &write) + +(define-enumeration &memory-kind-mask &memory-kind-bits + ;; Indicates than an expression may access unknown kinds of memory. + &unknown-memory-kinds + + ;; Indicates that an expression depends on the value of a fluid + ;; variable, or on the current fluid environment. + &fluid + + ;; Indicates that an expression depends on the current prompt + ;; stack. + &prompt + + ;; Indicates that an expression depends on the value of the car or cdr + ;; of a pair. + &pair + + ;; Indicates that an expression depends on the value of a vector + ;; field. The effect field indicates the specific field, or zero for + ;; an unknown field. + &vector + + ;; Indicates that an expression depends on the value of a variable + ;; cell. + &box + + ;; Indicates that an expression depends on the current module. + &module + + ;; Indicates that an expression depends on the current thread. + &thread + + ;; Indicates that an expression depends on the value of a struct + ;; field. The effect field indicates the specific field, or zero for + ;; an unknown field. + &struct + + ;; Indicates that an expression depends on the contents of a string. + &string + + ;; Indicates that an expression depends on the contents of a + ;; bytevector. We cannot be more precise, as bytevectors may alias + ;; other bytevectors. + &bytevector + + ;; Indicates a dependency on a free variable of a closure. + &closure + + ;; Indicates a dependency on a raw bitmask, measured in 32-bit units. + &bitmask + + ;; Indicates a dependency on the value of a cache cell. + &cache) + +(define-inlinable (&field kind field) + (ash (logior (ash field &memory-kind-bits) kind) &effect-kind-bits)) +(define-inlinable (&object kind) + (&field kind -1)) + +(define-inlinable (&allocate kind) + (logior &allocation (&object kind))) +(define-inlinable (&read-field kind field) + (logior &read (&field kind field))) +(define-inlinable (&read-object kind) + (logior &read (&object kind))) +(define-inlinable (&write-field kind field) + (logior &write (&field kind field))) +(define-inlinable (&write-object kind) + (logior &write (&object kind))) + +(define-syntax &no-effects (identifier-syntax 0)) +(define-syntax &all-effects + (identifier-syntax + (logior &all-effect-kinds (&object &unknown-memory-kinds)))) + +(define-inlinable (causes-effect? x effects) + (not (zero? (logand x effects)))) + +(define-inlinable (causes-all-effects? x) + (eqv? x &all-effects)) + +(define (effect-clobbers? a b) + "Return true if A clobbers B. This is the case if A is a write, and B +is or might be a read or a write to the same location as A." + (define (locations-same?) + (let ((a (ash a (- &effect-kind-bits))) + (b (ash b (- &effect-kind-bits)))) + (or (eqv? &unknown-memory-kinds (logand a &memory-kind-mask)) + (eqv? &unknown-memory-kinds (logand b &memory-kind-mask)) + (and (eqv? (logand a &memory-kind-mask) (logand b &memory-kind-mask)) + ;; A negative field indicates "the whole object". + ;; Non-negative fields indicate only part of the object. + (or (< a 0) (< b 0) (= a b)))))) + (and (not (zero? (logand a &write))) + (not (zero? (logand b (logior &read &write)))) + (locations-same?))) + +(define (compute-clobber-map effects) + "For the map LABEL->EFFECTS, compute a map LABEL->LABELS indicating +the LABELS that are clobbered by the effects of LABEL." + (let ((clobbered-by-write (make-hash-table))) + (intmap-fold + (lambda (label fx) + ;; Unless an expression causes a read, it isn't clobbered by + ;; anything. + (when (causes-effect? fx &read) + (let ((me (intset label))) + (define (add! kind field) + (let* ((k (logior (ash field &memory-kind-bits) kind)) + (clobber (hashv-ref clobbered-by-write k empty-intset))) + (hashv-set! clobbered-by-write k (intset-union me clobber)))) + ;; Clobbered by write to specific field of this memory + ;; kind, write to any field of this memory kind, or + ;; write to any field of unknown memory kinds. + (let* ((loc (ash fx (- &effect-kind-bits))) + (kind (logand loc &memory-kind-mask)) + (field (ash loc (- &memory-kind-bits)))) + (add! kind field) + (add! kind -1) + (add! &unknown-memory-kinds -1)))) + (values)) + effects) + (intmap-map (lambda (label fx) + (if (causes-effect? fx &write) + (hashv-ref clobbered-by-write + (ash fx (- &effect-kind-bits)) + empty-intset) + empty-intset)) + effects))) + +(define *primitive-effects* (make-hash-table)) + +(define-syntax-rule (define-primitive-effects* param + ((name . args) effects ...) + ...) + (begin + (hashq-set! *primitive-effects* 'name + (case-lambda* + ((param . args) (logior effects ...)) + (_ &all-effects))) + ...)) + +(define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...) + (define-primitive-effects* param ((name . args) effects ...) ...)) + +;; Miscellaneous. +(define-primitive-effects + ((load-const/unlikely)) + ((values . _))) + +;; Generic effect-free predicates. +(define-primitive-effects + ((eq? x y)) + ((equal? x y)) + ((fixnum? arg)) + ((char? arg)) + ((eq-null? arg)) + ((eq-nil? arg)) + ((eq-false? arg)) + ((eq-true? arg)) + ((unspecified? arg)) + ((undefined? arg)) + ((eof-object? arg)) + ((null? arg)) + ((false? arg)) + ((nil? arg)) + ((heap-object? arg)) + ((pair? arg)) + ((symbol? arg)) + ((variable? arg)) + ((vector? arg)) + ((struct? arg)) + ((string? arg)) + ((number? arg)) + ((bytevector? arg)) + ((keyword? arg)) + ((bitvector? arg)) + ((procedure? arg)) + ((thunk? arg)) + ((heap-number? arg)) + ((bignum? arg)) + ((flonum? arg)) + ((compnum? arg)) + ((fracnum? arg))) + +;; Fluids. +(define-primitive-effects + ((fluid-ref f) (&read-object &fluid) &type-check) + ((fluid-set! f v) (&write-object &fluid) &type-check) + ((push-fluid f v) (&write-object &fluid) &type-check) + ((pop-fluid) (&write-object &fluid)) + ((push-dynamic-state state) (&write-object &fluid) &type-check) + ((pop-dynamic-state) (&write-object &fluid))) + +;; Threads. Calls cause &all-effects, which reflects the fact that any +;; call can capture a partial continuation and reinstate it on another +;; thread. +(define-primitive-effects + ((current-thread) (&read-object &thread))) + +;; Prompts. +(define-primitive-effects + ((make-prompt-tag #:optional arg) (&allocate &unknown-memory-kinds))) + +;; Generic objects. +(define (annotation->memory-kind annotation) + (match annotation + ('pair &pair) + ('vector &vector) + ('string &string) + ('stringbuf &string) + ('bytevector &bytevector) + ('bitmask &bitmask) + ('box &box) + ('closure &closure) + ('struct &struct) + ('atomic-box &unknown-memory-kinds))) + +(define-primitive-effects* param + ((allocate-words size) (&allocate (annotation->memory-kind param))) + ((allocate-words/immediate) (match param + ((ann . size) + (&allocate + (annotation->memory-kind ann))))) + ((scm-ref obj idx) (&read-object + (annotation->memory-kind param))) + ((scm-ref/tag obj) (&read-field + (annotation->memory-kind param) 0)) + ((scm-ref/immediate obj) (match param + ((ann . idx) + (&read-field + (annotation->memory-kind ann) idx)))) + ((scm-set! obj idx val) (&write-object + (annotation->memory-kind param))) + ((scm-set/tag! obj val) (&write-field + (annotation->memory-kind param) 0)) + ((scm-set!/immediate obj val) (match param + ((ann . idx) + (&write-field + (annotation->memory-kind ann) idx)))) + ((word-ref obj idx) (&read-object + (annotation->memory-kind param))) + ((word-ref/immediate obj) (match param + ((ann . idx) + (&read-field + (annotation->memory-kind ann) idx)))) + ((word-set! obj idx val) (&read-object + (annotation->memory-kind param))) + ((word-set!/immediate obj val) (match param + ((ann . idx) + (&write-field + (annotation->memory-kind ann) idx)))) + ((pointer-ref/immediate obj) (match param + ((ann . idx) + (&read-field + (annotation->memory-kind ann) idx)))) + ((pointer-set!/immediate obj val) + (match param + ((ann . idx) + (&write-field + (annotation->memory-kind ann) idx)))) + ((tail-pointer-ref/immediate obj))) + +;; Strings. +(define-primitive-effects + ((string-set! s n c) (&write-object &string) &type-check) + ((number->string _) (&allocate &string) &type-check) + ((string->number _) (&read-object &string) &type-check)) + +;; Unboxed floats and integers. +(define-primitive-effects + ((scm->f64 _) &type-check) + ((load-f64)) + ((f64->scm _)) + ((scm->u64 _) &type-check) + ((scm->u64/truncate _) &type-check) + ((load-u64)) + ((u64->scm _)) + ((u64->scm/unlikely _)) + ((scm->s64 _) &type-check) + ((load-s64)) + ((s64->scm _)) + ((s64->scm/unlikely _)) + ((u64->s64 _)) + ((s64->u64 _)) + ((assume-u64 _)) + ((assume-s64 _)) + ((untag-fixnum _)) + ((tag-fixnum _)) + ((tag-fixnum/unlikely _))) + +;; Pointers. +(define-primitive-effects* param + ((u8-ref obj bv n) (&read-object (annotation->memory-kind param))) + ((s8-ref obj bv n) (&read-object (annotation->memory-kind param))) + ((u16-ref obj bv n) (&read-object (annotation->memory-kind param))) + ((s16-ref obj bv n) (&read-object (annotation->memory-kind param))) + ((u32-ref obj bv n) (&read-object (annotation->memory-kind param))) + ((s32-ref obj bv n) (&read-object (annotation->memory-kind param))) + ((u64-ref obj bv n) (&read-object (annotation->memory-kind param))) + ((s64-ref obj bv n) (&read-object (annotation->memory-kind param))) + ((f32-ref obj bv n) (&read-object (annotation->memory-kind param))) + ((f64-ref obj bv n) (&read-object (annotation->memory-kind param))) + + ((u8-set! obj bv n x) (&write-object (annotation->memory-kind param))) + ((s8-set! obj bv n x) (&write-object (annotation->memory-kind param))) + ((u16-set! obj bv n x) (&write-object (annotation->memory-kind param))) + ((s16-set! obj bv n x) (&write-object (annotation->memory-kind param))) + ((u32-set! obj bv n x) (&write-object (annotation->memory-kind param))) + ((s32-set! obj bv n x) (&write-object (annotation->memory-kind param))) + ((u64-set! obj bv n x) (&write-object (annotation->memory-kind param))) + ((s64-set! obj bv n x) (&write-object (annotation->memory-kind param))) + ((f32-set! obj bv n x) (&write-object (annotation->memory-kind param))) + ((f64-set! obj bv n x) (&write-object (annotation->memory-kind param)))) + +;; Modules. +(define-primitive-effects + ((current-module) (&read-object &module)) + ((cache-current-module! m) (&write-object &cache)) + ((resolve name) (&read-object &module) &type-check) + ((resolve-module mod) (&read-object &module) &type-check) + ((lookup mod name) (&read-object &module) &type-check) + ((cached-toplevel-box) &type-check) + ((cached-module-box) &type-check) + ((define! mod name) (&read-object &module))) + +;; Cache cells. +(define-primitive-effects + ((cache-ref) (&read-object &cache)) + ((cache-set! x) (&write-object &cache))) + +;; Numbers. +(define-primitive-effects + ((heap-numbers-equal? . _)) + ((= . _) &type-check) + ((<= . _) &type-check) + ((< . _) &type-check) + ((u64-= . _)) + ((u64-imm-= . _)) + ((u64-< . _)) + ((u64-imm-< . _)) + ((imm-u64-< . _)) + ((s64-= . _)) + ((s64-imm-= . _)) + ((s64-< . _)) + ((s64-imm-< . _)) + ((imm-s64-< . _)) + ((f64-= . _)) + ((f64-< . _)) + ((f64-<= . _)) + ((zero? . _) &type-check) + ((add . _) &type-check) + ((add/immediate . _) &type-check) + ((mul . _) &type-check) + ((sub . _) &type-check) + ((sub/immediate . _) &type-check) + ((div . _) &type-check) + ((fadd . _)) + ((fsub . _)) + ((fmul . _)) + ((fdiv . _)) + ((uadd . _)) + ((usub . _)) + ((umul . _)) + ((uadd/immediate . _)) + ((usub/immediate . _)) + ((umul/immediate . _)) + ((sadd . _)) + ((ssub . _)) + ((smul . _)) + ((sadd/immediate . _)) + ((ssub/immediate . _)) + ((smul/immediate . _)) + ((quo . _) &type-check) + ((rem . _) &type-check) + ((mod . _) &type-check) + ((complex? _) &type-check) + ((real? _) &type-check) + ((rational? _) &type-check) + ((inf? _) &type-check) + ((nan? _) &type-check) + ((integer? _) &type-check) + ((exact? _) &type-check) + ((inexact? _) &type-check) + ((even? _) &type-check) + ((odd? _) &type-check) + ((rsh n m) &type-check) + ((lsh n m) &type-check) + ((rsh/immediate n) &type-check) + ((lsh/immediate n) &type-check) + ((logand . _) &type-check) + ((logior . _) &type-check) + ((logxor . _) &type-check) + ((logsub . _) &type-check) + ((lognot . _) &type-check) + ((ulogand . _)) + ((ulogior . _)) + ((ulogxor . _)) + ((ulogsub . _)) + ((ursh . _)) + ((srsh . _)) + ((ulsh . _)) + ((slsh . _)) + ((ursh/immediate . _)) + ((srsh/immediate . _)) + ((ulsh/immediate . _)) + ((slsh/immediate . _)) + ((logtest a b) &type-check) + ((logbit? a b) &type-check) + ((sqrt _) &type-check) + ((abs _) &type-check)) + +;; Characters. +(define-primitive-effects + ((untag-char _)) + ((tag-char _))) + +;; Atomics are a memory and a compiler barrier; they cause all effects +;; so no need to have a case for them here. (Though, see +;; https://jfbastien.github.io/no-sane-compiler/.) + +(define (primitive-effects param name args) + (let ((proc (hashq-ref *primitive-effects* name))) + (if proc + (apply proc param args) + &all-effects))) + +(define (expression-effects exp) + (match exp + ((or ($ $const) ($ $prim) ($ $values) ($ $code) ($ $const-fun)) + &no-effects) + ((or ($ $fun) ($ $rec)) + (&allocate &unknown-memory-kinds)) + ((or ($ $call) ($ $callk)) + &all-effects) + (($ $primcall name param args) + (primitive-effects param name args)))) + +(define (compute-effects conts) + (intmap-map + (lambda (label cont) + (match cont + (($ $kargs names syms ($ $continue k src exp)) + (expression-effects exp)) + (($ $kargs names syms ($ $branch kf kt src op param args)) + (primitive-effects param op args)) + (($ $kargs names syms ($ $prompt)) + ;; Although the "main" path just writes &prompt, we don't know + ;; what nonlocal predecessors of the handler do, so we + ;; conservatively assume &all-effects. + &all-effects) + (($ $kargs names syms ($ $throw)) + ;; A reachable "throw" term can never be elided. + &all-effects) + (($ $kreceive arity kargs) + (match arity + (($ $arity _ () #f () #f) &type-check) + (($ $arity () () _ () #f) (&allocate &pair)) + (($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check)))) + (($ $kfun) &type-check) + (($ $kclause) &type-check) + (($ $ktail) &no-effects))) + conts)) + +;; There is a way to abuse effects analysis in CSE to also do scalar +;; replacement, effectively adding `car' and `cdr' expressions to `cons' +;; expressions, and likewise with other constructors and setters. This +;; routine adds appropriate effects to `cons' and `set-car!' and the +;; like. +;; +;; This doesn't affect CSE's ability to eliminate expressions, given +;; that allocations aren't eliminated anyway, and the new effects will +;; just cause the allocations not to commute with e.g. set-car! which +;; is what we want anyway. +(define (synthesize-definition-effects effects) + (intmap-map (lambda (label fx) + (if (logtest (logior &write &allocation) fx) + (logior fx &read) + fx)) + effects)) |