;;; Effects analysis on CPS

;; Copyright (C) 2011-2015,2017-2020 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
            &header

            &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

  ;; Indicates that an expression depends on a value extracted from the
  ;; fixed, unchanging part of an object -- for example the length of a
  ;; vector or the vtable of a struct.
  &header)

(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 idx)
  (match (cons annotation idx)
    (('vector . 0) &header)
    (('string . (or 0 1 2 3)) &header)
    (('stringbuf . (or 0 1)) &header)
    (('bytevector . (or 0 1 2 3)) &header)
    (('box . 0) &header)
    (('closure . (or 0 1)) &header)
    (('struct . 0) &header)
    (('atomic-box . 0) &header)
    (_ (annotation->memory-kind annotation))))

(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)))))
  ((allocate-pointerless-words size)
                                   (&allocate (annotation->memory-kind param)))
  ((allocate-pointerless-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) 0))
  ((scm-ref/immediate obj)         (match param
                                     ((ann . idx)
                                      (&read-field
                                       (annotation->memory-kind* ann idx) idx))))
  ((scm-set! obj idx val)          (&write-object
                                    (annotation->memory-kind param)))
  ((scm-set/tag! obj val)          (&write-field
                                    (annotation->memory-kind* param 0) 0))
  ((scm-set!/immediate obj val)    (match param
                                     ((ann . idx)
                                      (&write-field
                                       (annotation->memory-kind* ann idx) 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) 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) idx))))
  ((pointer-ref/immediate obj)     (match param
                                     ((ann . idx)
                                      (&read-field
                                       (annotation->memory-kind* ann idx) idx))))
  ((pointer-set!/immediate obj val)
                                   (match param
                                     ((ann . idx)
                                      (&write-field
                                       (annotation->memory-kind* ann idx) 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)
  ((module-variable mod name)      (&read-object &module)      &type-check)
  ((lookup mod name)               (&read-object &module)      &type-check)
  ((lookup-bound 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)
  ((inexact _)                     &type-check)
  ((s64->f64 _))
  ((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)
  ((floor _)                       &type-check)
  ((ceiling _)                     &type-check)
  ((sin _)                         &type-check)
  ((cos _)                         &type-check)
  ((tan _)                         &type-check)
  ((asin _)                        &type-check)
  ((acos _)                        &type-check)
  ((atan _)                        &type-check)
  ((atan2 x y)                     &type-check)
  ((fsqrt _))
  ((fabs _))
  ((ffloor _))
  ((fceiling _))
  ((fsin _))
  ((fcos _))
  ((ftan _))
  ((fasin _))
  ((facos _))
  ((fatan _))
  ((fatan2 x y)))

;; 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))