mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
d08cc4f6e2
* module/language/tree-il/primitives.scm (*interesting-primitive-names*): (*primitive-accessors*): Add string->utf8, utf8->string, and string-utf8-length. (primitive-module): New public function, moved here from (language tree-il compile-bytecode). * module/language/tree-il/compile-bytecode.scm: Use primitive-module from (language tree-il primitives). * module/language/tree-il/peval.scm (peval): A bugfix: load primitives from their proper module. Allows bytevector primitives to fold. * module/language/cps/guile-vm/reify-primitives.scm: * module/language/cps/effects-analysis.scm: * module/language/cps/types.scm * module/language/tree-il/primitives.scm: * module/language/tree-il/cps-primitives.scm: * module/language/tree-il/effects.scm (make-effects-analyzer): Add string->utf8, utf8->string, and string-utf8-length. * module/language/tree-il/compile-cps.scm (string->utf8) (string-utf8-length, utf8->string): New custom lowerers, including type checks and an unboxed result for string-utf8-length. * module/system/vm/assembler.scm: * libguile/intrinsics.h: * libguile/intrinsics.c: Because string-utf8-length returns an unboxed value, we need an intrinsic for it; go ahead and add an intrinsic for string->utf8 and utf8->string too, as we will likely be able to use these in the future.
619 lines
23 KiB
Scheme
619 lines
23 KiB
Scheme
;;; Effects analysis on Tree-IL
|
|
|
|
;; Copyright (C) 2011, 2012, 2013, 2021, 2023 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
|
|
|
|
(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 cannot 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> _ 'push-dynamic-state (state))
|
|
(logior (compute-effects state)
|
|
(cause &type-check)
|
|
(cause &fluid)))
|
|
|
|
(($ <primcall> _ 'pop-dynamic-state ())
|
|
(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> _ '%variable-ref (v))
|
|
(logior (compute-effects v)
|
|
(cause &type-check) ;; For the unbound check.
|
|
&variable))
|
|
(($ <primcall> _ '%variable-set! (v x))
|
|
(logior (compute-effects v)
|
|
(compute-effects x)
|
|
(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> _ 'string->utf8 (s))
|
|
(logior (compute-effects s)
|
|
(cause &type-check)
|
|
(cause &allocation)
|
|
&string))
|
|
(($ <primcall> _ 'string-utf8-length (s))
|
|
(logior (compute-effects s)
|
|
(cause &type-check)
|
|
&string))
|
|
(($ <primcall> _ 'utf8->string (bv))
|
|
(logior (compute-effects bv)
|
|
(cause &type-check)
|
|
(cause &allocation)
|
|
&bytevector))
|
|
|
|
(($ <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. Nota bene,
|
|
;; 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 (if escape-only?
|
|
body
|
|
(make-call #f body '())))
|
|
;; Calls handler with probably wrong argument count,
|
|
;; but that will just add a &type-check effect.
|
|
(compute-effects (make-call #f handler '()))))
|
|
|
|
(($ <abort> _ tag args tail)
|
|
(logior &all-effects-but-bailout
|
|
(cause &all-effects-but-bailout)))))
|
|
|
|
(compute-effects exp))
|
|
|
|
compute-effects))
|