  Effects analysis on Tree - IL

  Copyright ( C ) 2011 , 2012 , 2013 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 ,     USA

(define-module (language tree-il effects)
  #:use-module (language tree-il)
  #:use-module (language tree-il primitives)
  #:use-module (ice-9 match)
  #:export (make-effects-analyzer
            &mutable-lexical
            &toplevel
            &fluid
            &definite-bailout
            &possible-bailout
            &zero-values
            &allocation
            &type-check
            &all-effects
            effects-commute?
            exclude-effects
            effect-free?
            constant?
            depends-on-effects?
            causes-effects?))

;;;
;;; Hey, it's some effects analysis!  If you invoke
;;; `make-effects-analyzer', you get a procedure that computes the set
;;; of effects that an expression depends on and causes.  This
;;; information is useful when writing algorithms that move code around,
;;; while preserving the semantics of an input program.
;;;
  The effects set is represented by a bitfield , as a fixnum .   The set
;;; of possible effects is modelled rather coarsely.  For example, a
  toplevel reference to FOO is modelled as depending on the & toplevel
;;; effect, and causing a &type-check effect.  If any intervening code
  sets any toplevel variable , that will block motion of FOO .
;;;
  For each effect , two bits are reserved : one to indicate that an
;;; expression depends on the effect, and the other to indicate that an
;;; expression causes the effect.
;;;
  Since we have more bits in a fixnum on 64 - bit systems , we can be
  more precise without losing efficiency .   On a 32 - bit system , some of
;;; the more precise effects map to fewer bits.
;;;

(define-syntax define-effects
  (lambda (x)
    (syntax-case x ()
      ((_ all name ...)
       (with-syntax (((n ...) (iota (length #'(name ...)))))
         #'(begin
             (define-syntax name (identifier-syntax (ash 1 (* n 2))))
             ...
             (define-syntax all (identifier-syntax (logior name ...)))))))))

(define-syntax compile-time-cond
  (lambda (x)
    (syntax-case x (else)
      ((_ (else body ...))
       #'(begin body ...))
      ((_ (exp body ...) clause ...)
       (if (eval (syntax->datum #'exp) (current-module))
           #'(begin body ...)
           #'(compile-time-cond clause ...))))))

;; Here we define the effects, indicating the meaning of the effect.
;;
;; Effects that are described in a "depends on" sense can also be used
;; in the "causes" sense.
;;
;; Effects that are described as causing an effect are not usually used
;; in a "depends-on" sense.  Although the "depends-on" sense is used
;; when checking for the existence of the "causes" effect, the effects
;; analyzer will not associate the "depends-on" sense of these effects
;; with any expression.
;;
(compile-time-cond
 ((>= (logcount most-positive-fixnum) 60)
  (define-effects &all-effects
    ;; Indicates that an expression depends on the value of a mutable
    ;; lexical variable.
    &mutable-lexical

    ;; Indicates that an expression depends on the value of a toplevel
    ;; variable.
    &toplevel

    ;; Indicates that an expression depends on the value of a fluid
    ;; variable.
    &fluid

    ;; Indicates that an expression definitely causes a non-local,
    ;; non-resumable exit -- a bailout.  Only used in the "changes" sense.
    &definite-bailout

    ;; Indicates that an expression may cause a bailout.
    &possible-bailout

  Indicates than an expression may return zero values -- a " causes "
    ;; effect.
    &zero-values

    ;; Indicates that an expression may return a fresh object -- a
    ;; "causes" effect.
    &allocation

    ;; Indicates that an expression depends on the value of the car of a
    ;; pair.
    &car

    ;; Indicates that an expression depends on the value of the cdr of a
    ;; pair.
    &cdr

    ;; Indicates that an expression depends on the value of a vector
    ;; field.  We cannot be more precise, as vectors may alias other
    ;; vectors.
    &vector

    ;; Indicates that an expression depends on the value of a variable
    ;; cell.
    &variable

    ;; Indicates that an expression depends on the value of a particular
    ;; struct field.
    &struct-0 &struct-1 &struct-2 &struct-3 &struct-4 &struct-5 &struct-6+

    ;; Indicates that an expression depends on the contents of a string.
    &string

    ;; Indicates that an expression depends on the contents of a
  bytevector .   We can not be more precise , as bytevectors may alias
  other bytevectors .
    &bytevector

    ;; 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 depends on the contents of an unknown
  ;; struct field.
  (define-syntax &struct
    (identifier-syntax
     (logior &struct-1 &struct-2 &struct-3 &struct-4 &struct-5 &struct-6+))))

 (else
  ;; For systems with smaller fixnums, be less precise regarding struct
  ;; fields.
  (define-effects &all-effects
    &mutable-lexical
    &toplevel
    &fluid
    &definite-bailout
    &possible-bailout
    &zero-values
    &allocation
    &car
    &cdr
    &vector
    &variable
    &struct
    &string
    &bytevector
    &type-check)
  (define-syntax &struct-0 (identifier-syntax &struct))
  (define-syntax &struct-1 (identifier-syntax &struct))
  (define-syntax &struct-2 (identifier-syntax &struct))
  (define-syntax &struct-3 (identifier-syntax &struct))
  (define-syntax &struct-4 (identifier-syntax &struct))
  (define-syntax &struct-5 (identifier-syntax &struct))
  (define-syntax &struct-6+ (identifier-syntax &struct))))

(define-syntax &no-effects (identifier-syntax 0))

;; Definite bailout is an oddball effect.  Since it indicates that an
;; expression definitely causes bailout, it's not in the set of effects
;; of a call to an unknown procedure.  At the same time, it's also
;; special in that a definite bailout in a subexpression doesn't always
;; cause an outer expression to include &definite-bailout in its
;; effects.  For that reason we have to treat it specially.
;;
(define-syntax &all-effects-but-bailout
  (identifier-syntax
   (logand &all-effects (lognot &definite-bailout))))

(define-inlinable (cause effect)
  (ash effect 1))

(define-inlinable (&depends-on a)
  (logand a &all-effects))
(define-inlinable (&causes a)
  (logand a (cause &all-effects)))

(define (exclude-effects effects exclude)
  (logand effects (lognot (cause exclude))))
(define (effect-free? effects)
  (zero? (&causes effects)))
(define (constant? effects)
  (zero? effects))

(define-inlinable (depends-on-effects? x effects)
  (not (zero? (logand (&depends-on x) effects))))
(define-inlinable (causes-effects? x effects)
  (not (zero? (logand (&causes x) (cause effects)))))

(define-inlinable (effects-commute? a b)
  (and (not (causes-effects? a (&depends-on b)))
       (not (causes-effects? b (&depends-on a)))))

(define (make-effects-analyzer assigned-lexical?)
  "Returns a procedure of type EXP -> EFFECTS that analyzes the effects
of an expression."

  (let ((cache (make-hash-table)))
    (define* (compute-effects exp #:optional (lookup (lambda (x) #f)))
      (define (compute-effects exp)
        (or (hashq-ref cache exp)
            (let ((effects (visit exp)))
              (hashq-set! cache exp effects)
              effects)))

      (define (accumulate-effects exps)
        (let lp ((exps exps) (out &no-effects))
          (if (null? exps)
              out
              (lp (cdr exps) (logior out (compute-effects (car exps)))))))

      (define (visit exp)
        (match exp
          (($ <const>)
           &no-effects)
          (($ <void>)
           &no-effects)
          (($ <lexical-ref> _ _ gensym)
           (if (assigned-lexical? gensym)
               &mutable-lexical
               &no-effects))
          (($ <lexical-set> _ name gensym exp)
           (logior (cause &mutable-lexical)
                   (compute-effects exp)))
          (($ <let> _ names gensyms vals body)
           (logior (if (or-map assigned-lexical? gensyms)
                       (cause &allocation)
                       &no-effects)
                   (accumulate-effects vals)
                   (compute-effects body)))
          (($ <letrec> _ in-order? names gensyms vals body)
           (logior (if (or-map assigned-lexical? gensyms)
                       (cause &allocation)
                       &no-effects)
                   (accumulate-effects vals)
                   (compute-effects body)))
          (($ <fix> _ names gensyms vals body)
           (logior (if (or-map assigned-lexical? gensyms)
                       (cause &allocation)
                       &no-effects)
                   (accumulate-effects vals)
                   (compute-effects body)))
          (($ <let-values> _ producer consumer)
           (logior (compute-effects producer)
                   (compute-effects consumer)
                   (cause &type-check)))
          (($ <toplevel-ref>)
           (logior &toplevel
                   (cause &type-check)))
          (($ <module-ref>)
           (logior &toplevel
                   (cause &type-check)))
          (($ <module-set> _ mod name public? exp)
           (logior (cause &toplevel)
                   (cause &type-check)
                   (compute-effects exp)))
          (($ <toplevel-define> _ name exp)
           (logior (cause &toplevel)
                   (compute-effects exp)))
          (($ <toplevel-set> _ name exp)
           (logior (cause &toplevel)
                   (compute-effects exp)))
          (($ <primitive-ref>)
           &no-effects)
          (($ <conditional> _ test consequent alternate)
           (let ((tfx (compute-effects test))
                 (cfx (compute-effects consequent))
                 (afx (compute-effects alternate)))
             (if (causes-effects? (logior tfx (logand afx cfx))
                                  &definite-bailout)
                 (logior tfx cfx afx)
                 (exclude-effects (logior tfx cfx afx)
                                  &definite-bailout))))

  Zero values .
          (($ <primcall> _ 'values ())
           (cause &zero-values))

          ;; Effect-free primitives.
          (($ <primcall> _ (or 'values 'eq? 'eqv? 'equal?) args)
           (accumulate-effects args))

          (($ <primcall> _ (or 'not 'pair? 'null? 'list? 'symbol?
                               'vector? 'struct? 'string? 'number?
                               'char?)
              (arg))
           (compute-effects arg))

          ;; Primitives that allocate memory.
          (($ <primcall> _ 'cons (x y))
           (logior (compute-effects x) (compute-effects y)
                   &allocation))

          (($ <primcall> _ (or 'list 'vector) args)
           (logior (accumulate-effects args) &allocation))

          (($ <primcall> _ 'make-prompt-tag ())
           &allocation)

          (($ <primcall> _ 'make-prompt-tag (arg))
           (logior (compute-effects arg) &allocation))

          (($ <primcall> _ 'fluid-ref (fluid))
           (logior (compute-effects fluid)
                   (cause &type-check)
                   &fluid))

          (($ <primcall> _ 'fluid-set! (fluid exp))
           (logior (compute-effects fluid)
                   (compute-effects exp)
                   (cause &type-check)
                   (cause &fluid)))

          (($ <primcall> _ 'push-fluid (fluid val))
           (logior (compute-effects fluid)
                   (compute-effects val)
                   (cause &type-check)
                   (cause &fluid)))

          (($ <primcall> _ 'pop-fluid ())
           (logior (cause &fluid)))

          (($ <primcall> _ 'car (x))
           (logior (compute-effects x)
                   (cause &type-check)
                   &car))
          (($ <primcall> _ 'set-car! (x y))
           (logior (compute-effects x)
                   (compute-effects y)
                   (cause &type-check)
                   (cause &car)))

          (($ <primcall> _ 'cdr (x))
           (logior (compute-effects x)
                   (cause &type-check)
                   &cdr))
          (($ <primcall> _ 'set-cdr! (x y))
           (logior (compute-effects x)
                   (compute-effects y)
                   (cause &type-check)
                   (cause &cdr)))

          (($ <primcall> _ (or 'memq 'memv) (x y))
           (logior (compute-effects x)
                   (compute-effects y)
                   (cause &type-check)
                   &car &cdr))

          (($ <primcall> _ 'vector-ref (v n))
           (logior (compute-effects v)
                   (compute-effects n)
                   (cause &type-check)
                   &vector))
          (($ <primcall> _ 'vector-set! (v n x))
           (logior (compute-effects v)
                   (compute-effects n)
                   (compute-effects x)
                   (cause &type-check)
                   (cause &vector)))

          (($ <primcall> _ 'variable-ref (v))
           (logior (compute-effects v)
                   (cause &type-check)
                   &variable))
          (($ <primcall> _ 'variable-set! (v x))
           (logior (compute-effects v)
                   (compute-effects x)
                   (cause &type-check)
                   (cause &variable)))

          (($ <primcall> _ 'struct-ref (s n))
           (logior (compute-effects s)
                   (compute-effects n)
                   (cause &type-check)
                   (match n
                     (($ <const> _ 0) &struct-0)
                     (($ <const> _ 1) &struct-1)
                     (($ <const> _ 2) &struct-2)
                     (($ <const> _ 3) &struct-3)
                     (($ <const> _ 4) &struct-4)
                     (($ <const> _ 5) &struct-5)
                     (($ <const> _ _) &struct-6+)
                     (_ &struct))))
          (($ <primcall> _ 'struct-set! (s n x))
           (logior (compute-effects s)
                   (compute-effects n)
                   (compute-effects x)
                   (cause &type-check)
                   (match n
                     (($ <const> _ 0) (cause &struct-0))
                     (($ <const> _ 1) (cause &struct-1))
                     (($ <const> _ 2) (cause &struct-2))
                     (($ <const> _ 3) (cause &struct-3))
                     (($ <const> _ 4) (cause &struct-4))
                     (($ <const> _ 5) (cause &struct-5))
                     (($ <const> _ _) (cause &struct-6+))
                     (_ (cause &struct)))))

          (($ <primcall> _ 'string-ref (s n))
           (logior (compute-effects s)
                   (compute-effects n)
                   (cause &type-check)
                   &string))
          (($ <primcall> _ 'string-set! (s n c))
           (logior (compute-effects s)
                   (compute-effects n)
                   (compute-effects c)
                   (cause &type-check)
                   (cause &string)))

          (($ <primcall> _
              (or 'bytevector-u8-ref 'bytevector-s8-ref
                  'bytevector-u16-ref 'bytevector-u16-native-ref
                  'bytevector-s16-ref 'bytevector-s16-native-ref
                  'bytevector-u32-ref 'bytevector-u32-native-ref
                  'bytevector-s32-ref 'bytevector-s32-native-ref
                  'bytevector-u64-ref 'bytevector-u64-native-ref
                  'bytevector-s64-ref 'bytevector-s64-native-ref
                  'bytevector-ieee-single-ref 'bytevector-ieee-single-native-ref
                  'bytevector-ieee-double-ref 'bytevector-ieee-double-native-ref)
              (bv n))
           (logior (compute-effects bv)
                   (compute-effects n)
                   (cause &type-check)
                   &bytevector))
          (($ <primcall> _
              (or 'bytevector-u8-set! 'bytevector-s8-set!
                  'bytevector-u16-set! 'bytevector-u16-native-set!
                  'bytevector-s16-set! 'bytevector-s16-native-set!
                  'bytevector-u32-set! 'bytevector-u32-native-set!
                  'bytevector-s32-set! 'bytevector-s32-native-set!
                  'bytevector-u64-set! 'bytevector-u64-native-set!
                  'bytevector-s64-set! 'bytevector-s64-native-set!
                  'bytevector-ieee-single-set! 'bytevector-ieee-single-native-set!
                  'bytevector-ieee-double-set! 'bytevector-ieee-double-native-set!)
              (bv n x))
           (logior (compute-effects bv)
                   (compute-effects n)
                   (compute-effects x)
                   (cause &type-check)
                   (cause &bytevector)))

          ;; Primitives that are normally effect-free, but which might
  cause type checks or allocate memory .     ,
          ;; primitives that access mutable memory should be given their
          ;; own inline cases above!
          (($ <primcall> _ (and name (? effect-free-primitive?)) args)
           (logior (accumulate-effects args)
                   (cause &type-check)
                   (if (constructor-primitive? name)
                       (cause &allocation)
                       &no-effects)))
      
          ;; Lambda applications might throw wrong-number-of-args.
          (($ <call> _ ($ <lambda> _ _ body) args)
           (logior (accumulate-effects args)
                   (match body
                     (($ <lambda-case> _ req #f #f #f () syms body #f)
                      (logior (compute-effects body)
                              (if (= (length req) (length args))
                                  0
                                  (cause &type-check))))
                     (($ <lambda-case>)
                      (logior (compute-effects body)
                              (cause &type-check)))
                     (#f
                      ;; Calling a case-lambda with no clauses
                      ;; definitely causes bailout.
                      (logior (cause &definite-bailout)
                              (cause &possible-bailout))))))
        
  Bailout primitives .
          (($ <primcall> _ (? bailout-primitive? name) args)
           (logior (accumulate-effects args)
                   (cause &definite-bailout)
                   (cause &possible-bailout)))
          (($ <call> _
              (and proc
                   ($ <module-ref> _ mod name public?)
                   (? (lambda (_)
                        (false-if-exception
                         (procedure-property
                          (module-ref (if public?
                                          (resolve-interface mod)
                                          (resolve-module mod))
                                      name)
                          'definite-bailout?)))))
              args)
           (logior (compute-effects proc)
                   (accumulate-effects args)
                   (cause &definite-bailout)
                   (cause &possible-bailout)))

          ;; A call to a lexically bound procedure, perhaps labels
          ;; allocated.
          (($ <call> _ (and proc ($ <lexical-ref> _ _ sym)) args)
           (cond
            ((lookup sym)
             => (lambda (proc)
                  (compute-effects (make-call #f proc args))))
            (else
             (logior &all-effects-but-bailout
                     (cause &all-effects-but-bailout)))))

          ;; A call to an unknown procedure can do anything.
          (($ <primcall> _ name args)
           (logior &all-effects-but-bailout
                   (cause &all-effects-but-bailout)))
          (($ <call> _ proc args)
           (logior &all-effects-but-bailout
                   (cause &all-effects-but-bailout)))

          (($ <lambda> _ meta body)
           &no-effects)
          (($ <lambda-case> _ req opt rest kw inits gensyms body alt)
           (logior (exclude-effects (accumulate-effects inits)
                                    &definite-bailout)
                   (if (or-map assigned-lexical? gensyms)
                       (cause &allocation)
                       &no-effects)
                   (compute-effects body)
                   (if alt (compute-effects alt) &no-effects)))

          (($ <seq> _ head tail)
           (logior
  Returning zero values to a for - effect continuation is
            ;; not observable.
            (exclude-effects (compute-effects head)
                             (cause &zero-values))
            (compute-effects tail)))

          (($ <prompt> _ escape-only? tag body handler)
           (logior (compute-effects tag)
                   (compute-effects body)
                   (compute-effects handler)))

          (($ <abort> _ tag args tail)
           (logior &all-effects-but-bailout
                   (cause &all-effects-but-bailout)))))

      (compute-effects exp))

    compute-effects))

 This library is free software; you can redistribute it and/or
 modify it under the terms of the GNU Lesser General Public
 either
 
 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.
 
 License along with this library; if not, write to the Free Software

 Hey, it's some effects analysis!  If you invoke
 `make-effects-analyzer', you get a procedure that computes the set
 of effects that an expression depends on and causes.  This
 information is useful when writing algorithms that move code around,
 while preserving the semantics of an input program.

 of possible effects is modelled rather coarsely.  For example, a
 effect, and causing a &type-check effect.  If any intervening code

 expression depends on the effect, and the other to indicate that an
 expression causes the effect.

 the more precise effects map to fewer bits.

 Here we define the effects, indicating the meaning of the effect.

 Effects that are described in a "depends on" sense can also be used
 in the "causes" sense.

 Effects that are described as causing an effect are not usually used
 in a "depends-on" sense.  Although the "depends-on" sense is used
 when checking for the existence of the "causes" effect, the effects
 analyzer will not associate the "depends-on" sense of these effects
 with any expression.

 Indicates that an expression depends on the value of a mutable
 lexical variable.
 Indicates that an expression depends on the value of a toplevel
 variable.
 Indicates that an expression depends on the value of a fluid
 variable.
 Indicates that an expression definitely causes a non-local,
 non-resumable exit -- a bailout.  Only used in the "changes" sense.
 Indicates that an expression may cause a bailout.
 effect.
 Indicates that an expression may return a fresh object -- a
 "causes" effect.
 Indicates that an expression depends on the value of the car of a
 pair.
 Indicates that an expression depends on the value of the cdr of a
 pair.
 Indicates that an expression depends on the value of a vector
 field.  We cannot be more precise, as vectors may alias other
 vectors.
 Indicates that an expression depends on the value of a variable
 cell.
 Indicates that an expression depends on the value of a particular
 struct field.
 Indicates that an expression depends on the contents of a string.
 Indicates that an expression depends on the contents of a
 Indicates that an expression may cause a type check.  A type check,
 for the purposes of this analysis, is the possibility of throwing
 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).
 Indicates that an expression depends on the contents of an unknown
 struct field.
 For systems with smaller fixnums, be less precise regarding struct
 fields.
 Definite bailout is an oddball effect.  Since it indicates that an
 expression definitely causes bailout, it's not in the set of effects
 of a call to an unknown procedure.  At the same time, it's also
 special in that a definite bailout in a subexpression doesn't always
 cause an outer expression to include &definite-bailout in its
 effects.  For that reason we have to treat it specially.

 Effect-free primitives.
 Primitives that allocate memory.
 Primitives that are normally effect-free, but which might
 primitives that access mutable memory should be given their
 own inline cases above!
 Lambda applications might throw wrong-number-of-args.
 Calling a case-lambda with no clauses
 definitely causes bailout.
 A call to a lexically bound procedure, perhaps labels
 allocated.
 A call to an unknown procedure can do anything.
 not observable.
  Effects analysis on Tree - IL

  Copyright ( C ) 2011 , 2012 , 2013 Free Software Foundation , Inc.

  version 3 of the License , or ( at your option ) any later version .
  You should have received a copy of the GNU Lesser General Public
  Foundation , Inc. , 51 Franklin Street , Fifth Floor , Boston ,     USA

(define-module (language tree-il effects)
  #:use-module (language tree-il)
  #:use-module (language tree-il primitives)
  #:use-module (ice-9 match)
  #:export (make-effects-analyzer
            &mutable-lexical
            &toplevel
            &fluid
            &definite-bailout
            &possible-bailout
            &zero-values
            &allocation
            &type-check
            &all-effects
            effects-commute?
            exclude-effects
            effect-free?
            constant?
            depends-on-effects?
            causes-effects?))

  The effects set is represented by a bitfield , as a fixnum .   The set
  toplevel reference to FOO is modelled as depending on the & toplevel
  sets any toplevel variable , that will block motion of FOO .
  For each effect , two bits are reserved : one to indicate that an
  Since we have more bits in a fixnum on 64 - bit systems , we can be
  more precise without losing efficiency .   On a 32 - bit system , some of

(define-syntax define-effects
  (lambda (x)
    (syntax-case x ()
      ((_ all name ...)
       (with-syntax (((n ...) (iota (length #'(name ...)))))
         #'(begin
             (define-syntax name (identifier-syntax (ash 1 (* n 2))))
             ...
             (define-syntax all (identifier-syntax (logior name ...)))))))))

(define-syntax compile-time-cond
  (lambda (x)
    (syntax-case x (else)
      ((_ (else body ...))
       #'(begin body ...))
      ((_ (exp body ...) clause ...)
       (if (eval (syntax->datum #'exp) (current-module))
           #'(begin body ...)
           #'(compile-time-cond clause ...))))))

(compile-time-cond
 ((>= (logcount most-positive-fixnum) 60)
  (define-effects &all-effects
    &mutable-lexical

    &toplevel

    &fluid

    &definite-bailout

    &possible-bailout

  Indicates than an expression may return zero values -- a " causes "
    &zero-values

    &allocation

    &car

    &cdr

    &vector

    &variable

    &struct-0 &struct-1 &struct-2 &struct-3 &struct-4 &struct-5 &struct-6+

    &string

  bytevector .   We can not be more precise , as bytevectors may alias
  other bytevectors .
    &bytevector

  an exception the first time an expression is evaluated .   If the
    &type-check)

  (define-syntax &struct
    (identifier-syntax
     (logior &struct-1 &struct-2 &struct-3 &struct-4 &struct-5 &struct-6+))))

 (else
  (define-effects &all-effects
    &mutable-lexical
    &toplevel
    &fluid
    &definite-bailout
    &possible-bailout
    &zero-values
    &allocation
    &car
    &cdr
    &vector
    &variable
    &struct
    &string
    &bytevector
    &type-check)
  (define-syntax &struct-0 (identifier-syntax &struct))
  (define-syntax &struct-1 (identifier-syntax &struct))
  (define-syntax &struct-2 (identifier-syntax &struct))
  (define-syntax &struct-3 (identifier-syntax &struct))
  (define-syntax &struct-4 (identifier-syntax &struct))
  (define-syntax &struct-5 (identifier-syntax &struct))
  (define-syntax &struct-6+ (identifier-syntax &struct))))

(define-syntax &no-effects (identifier-syntax 0))

(define-syntax &all-effects-but-bailout
  (identifier-syntax
   (logand &all-effects (lognot &definite-bailout))))

(define-inlinable (cause effect)
  (ash effect 1))

(define-inlinable (&depends-on a)
  (logand a &all-effects))
(define-inlinable (&causes a)
  (logand a (cause &all-effects)))

(define (exclude-effects effects exclude)
  (logand effects (lognot (cause exclude))))
(define (effect-free? effects)
  (zero? (&causes effects)))
(define (constant? effects)
  (zero? effects))

(define-inlinable (depends-on-effects? x effects)
  (not (zero? (logand (&depends-on x) effects))))
(define-inlinable (causes-effects? x effects)
  (not (zero? (logand (&causes x) (cause effects)))))

(define-inlinable (effects-commute? a b)
  (and (not (causes-effects? a (&depends-on b)))
       (not (causes-effects? b (&depends-on a)))))

(define (make-effects-analyzer assigned-lexical?)
  "Returns a procedure of type EXP -> EFFECTS that analyzes the effects
of an expression."

  (let ((cache (make-hash-table)))
    (define* (compute-effects exp #:optional (lookup (lambda (x) #f)))
      (define (compute-effects exp)
        (or (hashq-ref cache exp)
            (let ((effects (visit exp)))
              (hashq-set! cache exp effects)
              effects)))

      (define (accumulate-effects exps)
        (let lp ((exps exps) (out &no-effects))
          (if (null? exps)
              out
              (lp (cdr exps) (logior out (compute-effects (car exps)))))))

      (define (visit exp)
        (match exp
          (($ <const>)
           &no-effects)
          (($ <void>)
           &no-effects)
          (($ <lexical-ref> _ _ gensym)
           (if (assigned-lexical? gensym)
               &mutable-lexical
               &no-effects))
          (($ <lexical-set> _ name gensym exp)
           (logior (cause &mutable-lexical)
                   (compute-effects exp)))
          (($ <let> _ names gensyms vals body)
           (logior (if (or-map assigned-lexical? gensyms)
                       (cause &allocation)
                       &no-effects)
                   (accumulate-effects vals)
                   (compute-effects body)))
          (($ <letrec> _ in-order? names gensyms vals body)
           (logior (if (or-map assigned-lexical? gensyms)
                       (cause &allocation)
                       &no-effects)
                   (accumulate-effects vals)
                   (compute-effects body)))
          (($ <fix> _ names gensyms vals body)
           (logior (if (or-map assigned-lexical? gensyms)
                       (cause &allocation)
                       &no-effects)
                   (accumulate-effects vals)
                   (compute-effects body)))
          (($ <let-values> _ producer consumer)
           (logior (compute-effects producer)
                   (compute-effects consumer)
                   (cause &type-check)))
          (($ <toplevel-ref>)
           (logior &toplevel
                   (cause &type-check)))
          (($ <module-ref>)
           (logior &toplevel
                   (cause &type-check)))
          (($ <module-set> _ mod name public? exp)
           (logior (cause &toplevel)
                   (cause &type-check)
                   (compute-effects exp)))
          (($ <toplevel-define> _ name exp)
           (logior (cause &toplevel)
                   (compute-effects exp)))
          (($ <toplevel-set> _ name exp)
           (logior (cause &toplevel)
                   (compute-effects exp)))
          (($ <primitive-ref>)
           &no-effects)
          (($ <conditional> _ test consequent alternate)
           (let ((tfx (compute-effects test))
                 (cfx (compute-effects consequent))
                 (afx (compute-effects alternate)))
             (if (causes-effects? (logior tfx (logand afx cfx))
                                  &definite-bailout)
                 (logior tfx cfx afx)
                 (exclude-effects (logior tfx cfx afx)
                                  &definite-bailout))))

  Zero values .
          (($ <primcall> _ 'values ())
           (cause &zero-values))

          (($ <primcall> _ (or 'values 'eq? 'eqv? 'equal?) args)
           (accumulate-effects args))

          (($ <primcall> _ (or 'not 'pair? 'null? 'list? 'symbol?
                               'vector? 'struct? 'string? 'number?
                               'char?)
              (arg))
           (compute-effects arg))

          (($ <primcall> _ 'cons (x y))
           (logior (compute-effects x) (compute-effects y)
                   &allocation))

          (($ <primcall> _ (or 'list 'vector) args)
           (logior (accumulate-effects args) &allocation))

          (($ <primcall> _ 'make-prompt-tag ())
           &allocation)

          (($ <primcall> _ 'make-prompt-tag (arg))
           (logior (compute-effects arg) &allocation))

          (($ <primcall> _ 'fluid-ref (fluid))
           (logior (compute-effects fluid)
                   (cause &type-check)
                   &fluid))

          (($ <primcall> _ 'fluid-set! (fluid exp))
           (logior (compute-effects fluid)
                   (compute-effects exp)
                   (cause &type-check)
                   (cause &fluid)))

          (($ <primcall> _ 'push-fluid (fluid val))
           (logior (compute-effects fluid)
                   (compute-effects val)
                   (cause &type-check)
                   (cause &fluid)))

          (($ <primcall> _ 'pop-fluid ())
           (logior (cause &fluid)))

          (($ <primcall> _ 'car (x))
           (logior (compute-effects x)
                   (cause &type-check)
                   &car))
          (($ <primcall> _ 'set-car! (x y))
           (logior (compute-effects x)
                   (compute-effects y)
                   (cause &type-check)
                   (cause &car)))

          (($ <primcall> _ 'cdr (x))
           (logior (compute-effects x)
                   (cause &type-check)
                   &cdr))
          (($ <primcall> _ 'set-cdr! (x y))
           (logior (compute-effects x)
                   (compute-effects y)
                   (cause &type-check)
                   (cause &cdr)))

          (($ <primcall> _ (or 'memq 'memv) (x y))
           (logior (compute-effects x)
                   (compute-effects y)
                   (cause &type-check)
                   &car &cdr))

          (($ <primcall> _ 'vector-ref (v n))
           (logior (compute-effects v)
                   (compute-effects n)
                   (cause &type-check)
                   &vector))
          (($ <primcall> _ 'vector-set! (v n x))
           (logior (compute-effects v)
                   (compute-effects n)
                   (compute-effects x)
                   (cause &type-check)
                   (cause &vector)))

          (($ <primcall> _ 'variable-ref (v))
           (logior (compute-effects v)
                   (cause &type-check)
                   &variable))
          (($ <primcall> _ 'variable-set! (v x))
           (logior (compute-effects v)
                   (compute-effects x)
                   (cause &type-check)
                   (cause &variable)))

          (($ <primcall> _ 'struct-ref (s n))
           (logior (compute-effects s)
                   (compute-effects n)
                   (cause &type-check)
                   (match n
                     (($ <const> _ 0) &struct-0)
                     (($ <const> _ 1) &struct-1)
                     (($ <const> _ 2) &struct-2)
                     (($ <const> _ 3) &struct-3)
                     (($ <const> _ 4) &struct-4)
                     (($ <const> _ 5) &struct-5)
                     (($ <const> _ _) &struct-6+)
                     (_ &struct))))
          (($ <primcall> _ 'struct-set! (s n x))
           (logior (compute-effects s)
                   (compute-effects n)
                   (compute-effects x)
                   (cause &type-check)
                   (match n
                     (($ <const> _ 0) (cause &struct-0))
                     (($ <const> _ 1) (cause &struct-1))
                     (($ <const> _ 2) (cause &struct-2))
                     (($ <const> _ 3) (cause &struct-3))
                     (($ <const> _ 4) (cause &struct-4))
                     (($ <const> _ 5) (cause &struct-5))
                     (($ <const> _ _) (cause &struct-6+))
                     (_ (cause &struct)))))

          (($ <primcall> _ 'string-ref (s n))
           (logior (compute-effects s)
                   (compute-effects n)
                   (cause &type-check)
                   &string))
          (($ <primcall> _ 'string-set! (s n c))
           (logior (compute-effects s)
                   (compute-effects n)
                   (compute-effects c)
                   (cause &type-check)
                   (cause &string)))

          (($ <primcall> _
              (or 'bytevector-u8-ref 'bytevector-s8-ref
                  'bytevector-u16-ref 'bytevector-u16-native-ref
                  'bytevector-s16-ref 'bytevector-s16-native-ref
                  'bytevector-u32-ref 'bytevector-u32-native-ref
                  'bytevector-s32-ref 'bytevector-s32-native-ref
                  'bytevector-u64-ref 'bytevector-u64-native-ref
                  'bytevector-s64-ref 'bytevector-s64-native-ref
                  'bytevector-ieee-single-ref 'bytevector-ieee-single-native-ref
                  'bytevector-ieee-double-ref 'bytevector-ieee-double-native-ref)
              (bv n))
           (logior (compute-effects bv)
                   (compute-effects n)
                   (cause &type-check)
                   &bytevector))
          (($ <primcall> _
              (or 'bytevector-u8-set! 'bytevector-s8-set!
                  'bytevector-u16-set! 'bytevector-u16-native-set!
                  'bytevector-s16-set! 'bytevector-s16-native-set!
                  'bytevector-u32-set! 'bytevector-u32-native-set!
                  'bytevector-s32-set! 'bytevector-s32-native-set!
                  'bytevector-u64-set! 'bytevector-u64-native-set!
                  'bytevector-s64-set! 'bytevector-s64-native-set!
                  'bytevector-ieee-single-set! 'bytevector-ieee-single-native-set!
                  'bytevector-ieee-double-set! 'bytevector-ieee-double-native-set!)
              (bv n x))
           (logior (compute-effects bv)
                   (compute-effects n)
                   (compute-effects x)
                   (cause &type-check)
                   (cause &bytevector)))

  cause type checks or allocate memory .     ,
          (($ <primcall> _ (and name (? effect-free-primitive?)) args)
           (logior (accumulate-effects args)
                   (cause &type-check)
                   (if (constructor-primitive? name)
                       (cause &allocation)
                       &no-effects)))
      
          (($ <call> _ ($ <lambda> _ _ body) args)
           (logior (accumulate-effects args)
                   (match body
                     (($ <lambda-case> _ req #f #f #f () syms body #f)
                      (logior (compute-effects body)
                              (if (= (length req) (length args))
                                  0
                                  (cause &type-check))))
                     (($ <lambda-case>)
                      (logior (compute-effects body)
                              (cause &type-check)))
                     (#f
                      (logior (cause &definite-bailout)
                              (cause &possible-bailout))))))
        
  Bailout primitives .
          (($ <primcall> _ (? bailout-primitive? name) args)
           (logior (accumulate-effects args)
                   (cause &definite-bailout)
                   (cause &possible-bailout)))
          (($ <call> _
              (and proc
                   ($ <module-ref> _ mod name public?)
                   (? (lambda (_)
                        (false-if-exception
                         (procedure-property
                          (module-ref (if public?
                                          (resolve-interface mod)
                                          (resolve-module mod))
                                      name)
                          'definite-bailout?)))))
              args)
           (logior (compute-effects proc)
                   (accumulate-effects args)
                   (cause &definite-bailout)
                   (cause &possible-bailout)))

          (($ <call> _ (and proc ($ <lexical-ref> _ _ sym)) args)
           (cond
            ((lookup sym)
             => (lambda (proc)
                  (compute-effects (make-call #f proc args))))
            (else
             (logior &all-effects-but-bailout
                     (cause &all-effects-but-bailout)))))

          (($ <primcall> _ name args)
           (logior &all-effects-but-bailout
                   (cause &all-effects-but-bailout)))
          (($ <call> _ proc args)
           (logior &all-effects-but-bailout
                   (cause &all-effects-but-bailout)))

          (($ <lambda> _ meta body)
           &no-effects)
          (($ <lambda-case> _ req opt rest kw inits gensyms body alt)
           (logior (exclude-effects (accumulate-effects inits)
                                    &definite-bailout)
                   (if (or-map assigned-lexical? gensyms)
                       (cause &allocation)
                       &no-effects)
                   (compute-effects body)
                   (if alt (compute-effects alt) &no-effects)))

          (($ <seq> _ head tail)
           (logior
  Returning zero values to a for - effect continuation is
            (exclude-effects (compute-effects head)
                             (cause &zero-values))
            (compute-effects tail)))

          (($ <prompt> _ escape-only? tag body handler)
           (logior (compute-effects tag)
                   (compute-effects body)
                   (compute-effects handler)))

          (($ <abort> _ tag args tail)
           (logior &all-effects-but-bailout
                   (cause &all-effects-but-bailout)))))

      (compute-effects exp))

    compute-effects))
