;;; package: (scode-optimizer analyze)
(declare (usual-integrations)
- (integrate-external "object"))
+ (integrate-external "object"))
\f
;;; EXPRESSION/ALWAYS-FALSE?
(define-method/always-false? 'COMBINATION
(lambda (expression)
(cond ((expression/call-to-not? expression)
- (expression/never-false? (first (combination/operands expression))))
- ((procedure? (combination/operator expression))
- (expression/always-false? (procedure/body (combination/operator expression))))
- (else #f))))
+ (expression/never-false? (first (combination/operands expression))))
+ ((procedure? (combination/operator expression))
+ (expression/always-false? (procedure/body (combination/operator expression))))
+ (else #f))))
(define-method/always-false? 'CONDITIONAL
(lambda (expression)
(and (or (expression/always-false? (conditional/predicate expression))
- (expression/always-false? (conditional/consequent expression)))
- (or (expression/never-false? (conditional/predicate expression))
- (expression/always-false? (conditional/alternative expression))))))
+ (expression/always-false? (conditional/consequent expression)))
+ (or (expression/never-false? (conditional/predicate expression))
+ (expression/always-false? (conditional/alternative expression))))))
(define-method/always-false? 'CONSTANT
(lambda (expression)
(define-method/always-false? 'DISJUNCTION
(lambda (expression)
(and (expression/always-false? (disjunction/predicate expression))
- (expression/always-false? (disjunction/alternative expression)))))
+ (expression/always-false? (disjunction/alternative expression)))))
(define-method/always-false? 'OPEN-BLOCK
(lambda (expression)
(define-method/boolean? 'COMBINATION
(lambda (expression)
(or (expression/call-to-boolean-predicate? expression)
- (and (procedure? (combination/operator expression))
- (boolean? (procedure/body (combination/operator expression)))))))
+ (and (procedure? (combination/operator expression))
+ (boolean? (procedure/body (combination/operator expression)))))))
(define-method/boolean? 'CONDITIONAL
(lambda (expression)
(and (or (expression/always-false? (conditional/predicate expression))
- (expression/boolean? (conditional/consequent expression)))
- (or (expression/never-false? (conditional/predicate expression))
- (expression/boolean? (conditional/alternative expression))))))
+ (expression/boolean? (conditional/consequent expression)))
+ (or (expression/never-false? (conditional/predicate expression))
+ (expression/boolean? (conditional/alternative expression))))))
(define-method/boolean? 'CONSTANT
(lambda (expression)
;; jrm: do not accept unspecific here.
(or (not (constant/value expression))
- (eq? (constant/value expression) #t))))
+ (eq? (constant/value expression) #t))))
(define-method/boolean? 'DECLARATION
(lambda (expression)
(define-method/boolean? 'DISJUNCTION
(lambda (expression)
(and (expression/boolean? (disjunction/predicate expression))
- (or (expression/never-false? (disjunction/predicate expression))
- (expression/boolean? (disjunction/alternative expression))))))
+ (or (expression/never-false? (disjunction/predicate expression))
+ (expression/boolean? (disjunction/alternative expression))))))
(define-method/boolean? 'OPEN-BLOCK
(lambda (expression)
(define-method/effect-free? 'COMBINATION
(lambda (expression)
(and (for-all? (combination/operands expression) expression/effect-free?)
- (or (expression/call-to-effect-free-primitive? expression)
- (and (procedure? (combination/operator expression))
- (expression/effect-free? (procedure/body (combination/operator expression))))))))
+ (or (expression/call-to-effect-free-primitive? expression)
+ (and (procedure? (combination/operator expression))
+ (expression/effect-free? (procedure/body (combination/operator expression))))))))
(define-method/effect-free? 'CONDITIONAL
(lambda (expression)
(and (expression/effect-free? (conditional/predicate expression))
- (or (expression/always-false? (conditional/predicate expression))
- (expression/effect-free? (conditional/consequent expression)))
- (or (expression/never-false? (conditional/predicate expression))
- (expression/effect-free? (conditional/alternative expression))))))
+ (or (expression/always-false? (conditional/predicate expression))
+ (expression/effect-free? (conditional/consequent expression)))
+ (or (expression/never-false? (conditional/predicate expression))
+ (expression/effect-free? (conditional/alternative expression))))))
(define-method/effect-free? 'CONSTANT true-procedure)
(define-method/effect-free? 'DISJUNCTION
(lambda (expression)
(and (expression/effect-free? (disjunction/predicate expression))
- (or (expression/never-false? (disjunction/predicate expression))
- (expression/effect-free? (disjunction/alternative expression))))))
+ (or (expression/never-false? (disjunction/predicate expression))
+ (expression/effect-free? (disjunction/alternative expression))))))
;; This could be smarter and skip the assignments
;; done for the letrec, but it is easier to just
(define (expressions/free-variables expressions)
(fold-left (lambda (answer expression)
- (lset-union eq? answer (expression/free-variables expression)))
- (no-free-variables)
- expressions))
+ (lset-union eq? answer (expression/free-variables expression)))
+ (no-free-variables)
+ expressions))
(define free-variables-dispatch-vector
(expression/make-dispatch-vector))
(define-method/free-variables 'ASSIGNMENT
(lambda (expression)
(lset-adjoin eq?
- (expression/free-variables (assignment/value expression))
- (assignment/variable expression))))
+ (expression/free-variables (assignment/value expression))
+ (assignment/variable expression))))
(define-method/free-variables 'COMBINATION
(lambda (expression)
(lset-union eq?
- (expression/free-variables (combination/operator expression))
- (expressions/free-variables (combination/operands expression)))))
+ (expression/free-variables (combination/operator expression))
+ (expressions/free-variables (combination/operands expression)))))
(define-method/free-variables 'CONDITIONAL
(lambda (expression)
(lset-union eq?
- (expression/free-variables (conditional/predicate expression))
- (if (expression/always-false? (conditional/predicate expression))
- (no-free-variables)
- (expression/free-variables (conditional/consequent expression)))
- (if (expression/never-false? (conditional/predicate expression))
- (no-free-variables)
- (expression/free-variables (conditional/alternative expression))))))
+ (expression/free-variables (conditional/predicate expression))
+ (if (expression/always-false? (conditional/predicate expression))
+ (no-free-variables)
+ (expression/free-variables (conditional/consequent expression)))
+ (if (expression/never-false? (conditional/predicate expression))
+ (no-free-variables)
+ (expression/free-variables (conditional/alternative expression))))))
(define-method/free-variables 'CONSTANT
(lambda (expression)
(define-method/free-variables 'DISJUNCTION
(lambda (expression)
(lset-union eq?
- (expression/free-variables (disjunction/predicate expression))
- (if (expression/never-false? (disjunction/predicate expression))
- (no-free-variables)
- (expression/free-variables (disjunction/alternative expression))))))
+ (expression/free-variables (disjunction/predicate expression))
+ (if (expression/never-false? (disjunction/predicate expression))
+ (no-free-variables)
+ (expression/free-variables (disjunction/alternative expression))))))
(define-method/free-variables 'OPEN-BLOCK
(lambda (expression)
(let ((omit (block/bound-variables (open-block/block expression))))
(fold-left (lambda (variables action)
- (if (eq? action open-block/value-marker)
- variables
- (lset-union eq? variables (lset-difference eq? (expression/free-variables action) omit))))
- (lset-difference eq? (expressions/free-variables (open-block/values expression)) omit)
- (open-block/actions expression)))))
+ (if (eq? action open-block/value-marker)
+ variables
+ (lset-union eq? variables (lset-difference eq? (expression/free-variables action) omit))))
+ (lset-difference eq? (expressions/free-variables (open-block/values expression)) omit)
+ (open-block/actions expression)))))
(define-method/free-variables 'PROCEDURE
(lambda (expression)
(define (expressions/free-variable? expressions variable)
(fold-left (lambda (answer expression)
- (or answer
- (expression/free-variable? expression variable)))
- #f
- expressions))
+ (or answer
+ (expression/free-variable? expression variable)))
+ #f
+ expressions))
(define is-free-dispatch-vector
(expression/make-dispatch-vector))
(define-method/free-variable? 'ASSIGNMENT
(lambda (expression variable)
(or (eq? variable (assignment/variable expression))
- (expression/free-variable? (assignment/value expression) variable))))
+ (expression/free-variable? (assignment/value expression) variable))))
(define-method/free-variable? 'COMBINATION
(lambda (expression variable)
(or (expression/free-variable? (combination/operator expression) variable)
- (expressions/free-variable? (combination/operands expression) variable))))
+ (expressions/free-variable? (combination/operands expression) variable))))
(define-method/free-variable? 'CONDITIONAL
(lambda (expression variable)
(or (expression/free-variable? (conditional/predicate expression) variable)
- (cond ((expression/always-false? (conditional/predicate expression))
- (expression/free-variable? (conditional/alternative expression) variable))
- ((expression/never-false? (conditional/predicate expression))
- (expression/free-variable? (conditional/consequent expression) variable))
- ((expression/free-variable? (conditional/consequent expression) variable))
- (else (expression/free-variable? (conditional/alternative expression) variable))))))
+ (cond ((expression/always-false? (conditional/predicate expression))
+ (expression/free-variable? (conditional/alternative expression) variable))
+ ((expression/never-false? (conditional/predicate expression))
+ (expression/free-variable? (conditional/consequent expression) variable))
+ ((expression/free-variable? (conditional/consequent expression) variable))
+ (else (expression/free-variable? (conditional/alternative expression) variable))))))
(define-method/free-variable? 'CONSTANT false-procedure)
(define-method/free-variable? 'DISJUNCTION
(lambda (expression variable)
(or (expression/free-variable? (disjunction/predicate expression) variable)
- (if (expression/never-false? (disjunction/predicate expression))
- #f
- (expression/free-variable? (disjunction/alternative expression) variable)))))
+ (if (expression/never-false? (disjunction/predicate expression))
+ #f
+ (expression/free-variable? (disjunction/alternative expression) variable)))))
(define-method/free-variable? 'OPEN-BLOCK
(lambda (expression variable)
(fold-left (lambda (answer action)
- (or answer
- (if (eq? action open-block/value-marker)
- #f
- (expression/free-variable? action variable))))
- #f
- (open-block/actions expression))))
+ (or answer
+ (if (eq? action open-block/value-marker)
+ #f
+ (expression/free-variable? action variable))))
+ #f
+ (open-block/actions expression))))
(define-method/free-variable? 'PROCEDURE
(lambda (expression variable)
(define-method/free-variable? 'SEQUENCE
(lambda (expression variable)
(fold-left (lambda (answer action)
- (or answer
- (if (eq? action open-block/value-marker)
- #f
- (expression/free-variable? action variable))))
- #f
- (sequence/actions expression))))
+ (or answer
+ (if (eq? action open-block/value-marker)
+ #f
+ (expression/free-variable? action variable))))
+ #f
+ (sequence/actions expression))))
(define-method/free-variable? 'THE-ENVIRONMENT false-procedure)
\f
(define (expressions/free-variable-info expressions variable info)
(fold-left (lambda (answer expression)
- (expression/free-variable-info-dispatch expression variable answer))
- info
- expressions))
+ (expression/free-variable-info-dispatch expression variable answer))
+ info
+ expressions))
(define free-info-dispatch-vector
(expression/make-dispatch-vector))
(define-method/free-variable-info 'ASSIGNMENT
(lambda (expression variable info)
(or (eq? variable (assignment/variable expression))
- (expression/free-variable-info-dispatch (assignment/value expression) variable info))))
+ (expression/free-variable-info-dispatch (assignment/value expression) variable info))))
(define-method/free-variable-info 'COMBINATION
(lambda (expression variable info)
(let ((operator (combination/operator expression))
- (inner-info (expressions/free-variable-info (combination/operands expression) variable info)))
+ (inner-info (expressions/free-variable-info (combination/operands expression) variable info)))
(if (and (reference? operator)
- (eq? (reference/variable operator) variable))
- (cons (fix:1+ (car inner-info)) (cdr inner-info))
- (expression/free-variable-info-dispatch operator variable inner-info)))))
+ (eq? (reference/variable operator) variable))
+ (cons (fix:1+ (car inner-info)) (cdr inner-info))
+ (expression/free-variable-info-dispatch operator variable inner-info)))))
(define-method/free-variable-info 'CONDITIONAL
(lambda (expression variable info)
(define-method/free-variable-info 'OPEN-BLOCK
(lambda (expression variable info)
(fold-left (lambda (info action)
- (if (eq? action open-block/value-marker)
- info
- (expression/free-variable-info-dispatch action variable info)))
- info
- (open-block/actions expression))))
+ (if (eq? action open-block/value-marker)
+ info
+ (expression/free-variable-info-dispatch action variable info)))
+ info
+ (open-block/actions expression))))
(define-method/free-variable-info 'PROCEDURE
(lambda (expression variable info)
(define-method/free-variable-info 'REFERENCE
(lambda (expression variable info)
(if (eq? (reference/variable expression) variable)
- (cons (car info) (fix:1+ (cdr info)))
- info)))
+ (cons (car info) (fix:1+ (cdr info)))
+ info)))
(define-method/free-variable-info 'SEQUENCE
(lambda (expression variable info)
(define-method/never-false? 'COMBINATION
(lambda (expression)
(cond ((expression/call-to-not? expression)
- (expression/always-false? (first (combination/operands expression))))
- ((procedure? (combination/operator expression))
- (expression/never-false? (procedure/body (combination/operator expression))))
- (else #f))))
+ (expression/always-false? (first (combination/operands expression))))
+ ((procedure? (combination/operator expression))
+ (expression/never-false? (procedure/body (combination/operator expression))))
+ (else #f))))
(define-method/never-false? 'CONDITIONAL
(lambda (expression)
(and (or (expression/always-false? (conditional/predicate expression))
- (expression/never-false? (conditional/consequent expression)))
- (or (expression/never-false? (conditional/predicate expression))
- (expression/never-false? (conditional/alternative expression))))))
+ (expression/never-false? (conditional/consequent expression)))
+ (or (expression/never-false? (conditional/predicate expression))
+ (expression/never-false? (conditional/alternative expression))))))
(define-method/never-false? 'CONSTANT constant/value)
(define-method/never-false? 'DISJUNCTION
(lambda (expression)
(or (expression/never-false? (disjunction/predicate expression))
- (expression/never-false? (disjunction/alternative expression)))))
+ (expression/never-false? (disjunction/alternative expression)))))
(define-method/never-false? 'OPEN-BLOCK
(lambda (expression)
(define-method/pure-false? 'COMBINATION
(lambda (expression)
(cond ((expression/call-to-not? expression)
- (expression/pure-true? (first (combination/operands expression))))
- ((procedure? (combination/operator expression))
- (and (for-all? (combination/operands expression) expression/effect-free?)
- (expression/pure-false? (procedure/body (combination/operator expression)))))
- (else #f))))
+ (expression/pure-true? (first (combination/operands expression))))
+ ((procedure? (combination/operator expression))
+ (and (for-all? (combination/operands expression) expression/effect-free?)
+ (expression/pure-false? (procedure/body (combination/operator expression)))))
+ (else #f))))
(define-method/pure-false? 'CONDITIONAL
(lambda (expression)
(and (expression/effect-free? (conditional/predicate expression))
- (or (expression/always-false? (conditional/predicate expression))
- (expression/pure-false? (conditional/consequent expression)))
- (or (expression/never-false? (conditional/predicate expression))
- (expression/pure-false? (conditional/alternative expression))))))
+ (or (expression/always-false? (conditional/predicate expression))
+ (expression/pure-false? (conditional/consequent expression)))
+ (or (expression/never-false? (conditional/predicate expression))
+ (expression/pure-false? (conditional/alternative expression))))))
(define-method/pure-false? 'CONSTANT
(lambda (expression)
(define-method/pure-false? 'DISJUNCTION
(lambda (expression)
(and (expression/pure-false? (disjunction/predicate expression))
- (expression/pure-false? (disjunction/alternative expression)))))
+ (expression/pure-false? (disjunction/alternative expression)))))
;; Could be smarter
(define-method/pure-false? 'OPEN-BLOCK false-procedure)
(define-method/pure-false? 'SEQUENCE
(lambda (expression)
(and (for-all? (except-last-pair (sequence/actions expression))
- expression/effect-free?) ;; unlikely
- (expression/pure-false? (last (sequence/actions expression))))))
+ expression/effect-free?) ;; unlikely
+ (expression/pure-false? (last (sequence/actions expression))))))
(define-method/pure-false? 'THE-ENVIRONMENT false-procedure)
\f
(define-method/pure-true? 'COMBINATION
(lambda (expression)
(cond ((expression/call-to-not? expression)
- (expression/pure-false? (first (combination/operands expression))))
- ((procedure? (combination/operator expression))
- (and (for-all? (combination/operands expression) expression/effect-free?)
- (expression/pure-true? (procedure/body (combination/operator expression)))))
- (else #f))))
+ (expression/pure-false? (first (combination/operands expression))))
+ ((procedure? (combination/operator expression))
+ (and (for-all? (combination/operands expression) expression/effect-free?)
+ (expression/pure-true? (procedure/body (combination/operator expression)))))
+ (else #f))))
(define-method/pure-true? 'CONDITIONAL
(lambda (expression)
(and (expression/effect-free? (conditional/predicate expression))
- (or (expression/always-false? (conditional/predicate expression))
- (expression/pure-true? (conditional/consequent expression)))
- (or (expression/never-false? (conditional/predicate expression))
- (expression/pure-true? (conditional/alternative expression))))))
+ (or (expression/always-false? (conditional/predicate expression))
+ (expression/pure-true? (conditional/consequent expression)))
+ (or (expression/never-false? (conditional/predicate expression))
+ (expression/pure-true? (conditional/alternative expression))))))
(define-method/pure-true? 'CONSTANT
(lambda (expression)
(define-method/pure-true? 'DISJUNCTION
(lambda (expression)
(and (expression/effect-free? (disjunction/predicate expression))
- (expression/boolean? (disjunction/predicate expression))
- (expression/pure-true? (disjunction/alternative expression)))))
+ (expression/boolean? (disjunction/predicate expression))
+ (expression/pure-true? (disjunction/alternative expression)))))
(define-method/pure-true? 'OPEN-BLOCK false-procedure)
(define-method/pure-true? 'SEQUENCE
(lambda (expression)
(and (for-all? (except-last-pair (sequence/actions expression))
- expression/effect-free?)
- (expression/pure-true? (last (sequence/actions expression))))))
+ expression/effect-free?)
+ (expression/pure-true? (last (sequence/actions expression))))))
(define-method/pure-true? 'THE-ENVIRONMENT false-procedure)
\f
(define-method/size 'COMBINATION
(lambda (expression)
(fold-left (lambda (total operand)
- (fix:+ total (expression/size operand)))
- (fix:1+ (expression/size (combination/operator expression)))
- (combination/operands expression))))
+ (fix:+ total (expression/size operand)))
+ (fix:1+ (expression/size (combination/operator expression)))
+ (combination/operands expression))))
(define-method/size 'CONDITIONAL
(lambda (expression)
- (fix:+
+ (fix:+
(expression/size (conditional/predicate expression))
(fix:+
(expression/size (conditional/consequent expression))
(define-method/size 'DISJUNCTION
(lambda (expression)
(fix:+ (expression/size (disjunction/predicate expression))
- (fix:1+ (expression/size (disjunction/alternative expression))))))
+ (fix:1+ (expression/size (disjunction/alternative expression))))))
(define-method/size 'OPEN-BLOCK
(lambda (expression)
(fold-left (lambda (total action)
- (if (eq? action open-block/value-marker)
- total
- (fix:+ total (expression/size action))))
- 1
- (open-block/actions expression))))
+ (if (eq? action open-block/value-marker)
+ total
+ (fix:+ total (expression/size action))))
+ 1
+ (open-block/actions expression))))
(define-method/size 'PROCEDURE
(lambda (expression)
(define-method/size 'SEQUENCE
(lambda (expression)
(fold-left (lambda (total action)
- (fix:+ total (expression/size action)))
- 1
- (sequence/actions expression))))
+ (fix:+ total (expression/size action)))
+ 1
+ (sequence/actions expression))))
(define (enumeration/make names)
(let ((enumerands
- (let loop ((names names) (index 0))
- (if (pair? names)
- (cons (vector #f (car names) index)
- (loop (cdr names) (1+ index)))
- '()))))
+ (let loop ((names names) (index 0))
+ (if (pair? names)
+ (cons (vector #f (car names) index)
+ (loop (cdr names) (1+ index)))
+ '()))))
(let ((enumeration
- (cons (list->vector enumerands)
- (map (lambda (enumerand)
- (cons (enumerand/name enumerand) enumerand))
- enumerands))))
+ (cons (list->vector enumerands)
+ (map (lambda (enumerand)
+ (cons (enumerand/name enumerand) enumerand))
+ enumerands))))
(for-each (lambda (enumerand)
- (vector-set! enumerand 0 enumeration))
- enumerands)
+ (vector-set! enumerand 0 enumeration))
+ enumerands)
enumeration)))
(define-structure (enumerand (type vector)
- (conc-name enumerand/))
+ (conc-name enumerand/))
(enumeration #f read-only #t)
(name #f read-only #t)
(index #f read-only #t))
(define (enumeration/name->enumerand enumeration name)
(cdr (or (assq name (cdr enumeration))
- (error "Unknown enumeration name:" name))))
+ (error "Unknown enumeration name:" name))))
(define-integrable (enumeration/name->index enumeration name)
(enumerand/index (enumeration/name->enumerand enumeration name)))
(sc-macro-transformer
(lambda (form environment)
(let ((enumeration-name (cadr form))
- (enumerand-names (caddr form)))
+ (enumerand-names (caddr form)))
`(BEGIN
- (DEFINE ,enumeration-name
- (ENUMERATION/MAKE ',enumerand-names))
- ,@(map (lambda (enumerand-name)
- `(DEFINE ,(symbol-append enumerand-name '/ENUMERAND)
- (ENUMERATION/NAME->ENUMERAND
- ,(close-syntax enumeration-name environment)
- ',enumerand-name)))
- enumerand-names))))))
+ (DEFINE ,enumeration-name
+ (ENUMERATION/MAKE ',enumerand-names))
+ ,@(map (lambda (enumerand-name)
+ `(DEFINE ,(symbol-append enumerand-name '/ENUMERAND)
+ (ENUMERATION/NAME->ENUMERAND
+ ,(close-syntax enumeration-name environment)
+ ',enumerand-name)))
+ enumerand-names))))))
(define-enumeration enumeration/random
(block
(sc-macro-transformer
(lambda (form environment)
(let ((name (second form))
- (constructor-name (third form)) ;; symbol or #F
- (slots (fourth form)))
+ (constructor-name (third form)) ;; symbol or #F
+ (slots (fourth form)))
`(BEGIN
- (DEFINE-STRUCTURE
- (,name
- (TYPE VECTOR)
- (NAMED
- ,(close-syntax (symbol-append name '/ENUMERAND) environment))
- (TYPE-DESCRIPTOR ,(symbol-append 'RTD: name))
- (CONC-NAME ,(symbol-append name '/))
- (CONSTRUCTOR ,(or constructor-name
- (symbol-append name '/MAKE))))
- (scode #f read-only #t)
- ,@slots)
- (DEFINE-GUARANTEE ,name ,(symbol->string name)))))))
+ (DEFINE-STRUCTURE
+ (,name
+ (TYPE VECTOR)
+ (NAMED
+ ,(close-syntax (symbol-append name '/ENUMERAND) environment))
+ (TYPE-DESCRIPTOR ,(symbol-append 'RTD: name))
+ (CONC-NAME ,(symbol-append name '/))
+ (CONSTRUCTOR ,(or constructor-name
+ (symbol-append name '/MAKE))))
+ (scode #f read-only #t)
+ ,@slots)
+ (DEFINE-GUARANTEE ,name ,(symbol->string name)))))))
;;; These accessors apply to all the record types.
(define-integrable (object/enumerand object)
;;; BLOCK
(define-structure (block (type vector)
- (named block/enumerand)
- (conc-name block/)
- (constructor block/%make
- (parent safe? bound-variables)))
+ (named block/enumerand)
+ (conc-name block/)
+ (constructor block/%make
+ (parent safe? bound-variables)))
parent
(children '())
safe?
(define (block/make parent safe? bound-variables)
(let ((block (block/%make parent safe? bound-variables)))
(if parent
- (set-block/children! parent (cons block (block/children parent))))
+ (set-block/children! parent (cons block (block/children parent))))
block))
;;; DELAYED-INTEGRATION
(define-structure (delayed-integration
- (type vector)
- (named delayed-integration/enumerand)
- (conc-name delayed-integration/)
- (constructor delayed-integration/make (operations value)))
+ (type vector)
+ (named delayed-integration/enumerand)
+ (conc-name delayed-integration/)
+ (constructor delayed-integration/make (operations value)))
(state 'NOT-INTEGRATED)
(environment #f)
operations
;; This makes debugging an awful lot easier.
;; Note that there is no SCODE slot.
(define-structure (variable
- (type vector)
- (named variable/enumerand)
- (type-descriptor rtd:variable)
- (conc-name variable/)
- (constructor variable/make (block name flags))
- (print-procedure
- (standard-unparser-method
- 'variable
- (lambda (var port)
- (write-string " " port)
- (write (variable/name var) port)))))
+ (type vector)
+ (named variable/enumerand)
+ (type-descriptor rtd:variable)
+ (conc-name variable/)
+ (constructor variable/make (block name flags))
+ (print-procedure
+ (standard-unparser-method
+ 'variable
+ (lambda (var port)
+ (write-string " " port)
+ (write (variable/name var) port)))))
block
name
flags)
;; The primitive predicates that only return #T or #F.
(define primitive-boolean-predicates
(map (lambda (name)
- (make-primitive-procedure name #t))
+ (make-primitive-procedure name #t))
'(
- %RECORD?
- &<
- &=
- &>
- BIT-STRING?
- CELL?
- CHAR-ASCII?
- CHAR?
- EQ?
- EQUAL-FIXNUM?
- FIXNUM?
- FLONUM-EQUAL?
- FLONUM-GREATER?
- FLONUM-LESS?
- FLONUM-NEGATIVE?
- FLONUM-POSITIVE?
- FLONUM-ZERO?
- FLONUM?
- GREATER-THAN-FIXNUM?
- INDEX-FIXNUM?
- INTEGER-EQUAL?
- INTEGER-GREATER?
- INTEGER-LESS?
- INTEGER-NEGATIVE?
- INTEGER-POSITIVE?
- INTEGER-ZERO?
- LESS-THAN-FIXNUM?
- NEGATIVE-FIXNUM?
- NEGATIVE?
- NOT
- NULL?
- OBJECT-TYPE?
- PAIR?
- POSITIVE-FIXNUM?
- POSITIVE?
- STRING?
- VECTOR?
- ZERO-FIXNUM?
- ZERO?
- )))
+ %RECORD?
+ &<
+ &=
+ &>
+ BIT-STRING?
+ CELL?
+ CHAR-ASCII?
+ CHAR?
+ EQ?
+ EQUAL-FIXNUM?
+ FIXNUM?
+ FLONUM-EQUAL?
+ FLONUM-GREATER?
+ FLONUM-LESS?
+ FLONUM-NEGATIVE?
+ FLONUM-POSITIVE?
+ FLONUM-ZERO?
+ FLONUM?
+ GREATER-THAN-FIXNUM?
+ INDEX-FIXNUM?
+ INTEGER-EQUAL?
+ INTEGER-GREATER?
+ INTEGER-LESS?
+ INTEGER-NEGATIVE?
+ INTEGER-POSITIVE?
+ INTEGER-ZERO?
+ LESS-THAN-FIXNUM?
+ NEGATIVE-FIXNUM?
+ NEGATIVE?
+ NOT
+ NULL?
+ OBJECT-TYPE?
+ PAIR?
+ POSITIVE-FIXNUM?
+ POSITIVE?
+ STRING?
+ VECTOR?
+ ZERO-FIXNUM?
+ ZERO?
+ )))
;; True if expression is a call to one of the primitive-boolean-predicates.
(define (expression/call-to-boolean-predicate? expression)
(and (combination? expression)
(let ((operator (combination/operator expression)))
- (and (constant? operator)
- (let ((operator-value (constant/value operator)))
- (and (memq operator-value primitive-boolean-predicates)
- (procedure-arity-valid?
- operator-value
- (length (combination/operands expression)))))))))
+ (and (constant? operator)
+ (let ((operator-value (constant/value operator)))
+ (and (memq operator-value primitive-boolean-predicates)
+ (procedure-arity-valid?
+ operator-value
+ (length (combination/operands expression)))))))))
;; These primitives have no side effects. We consider primitives
;; that check their arguments *have* a side effect. (Conservative)
(define effect-free-primitives
(map (lambda (name)
- (make-primitive-procedure name #t))
+ (make-primitive-procedure name #t))
'(
- %RECORD?
- BIT-STRING?
- CELL?
- CHAR?
- EQ?
- FIXNUM?
- FLONUM?
- NOT
- NULL?
- OBJECT-TYPE
- OBJECT-TYPE?
- PAIR?
- STRING?
- VECTOR?
- )))
+ %RECORD?
+ BIT-STRING?
+ CELL?
+ CHAR?
+ EQ?
+ FIXNUM?
+ FLONUM?
+ NOT
+ NULL?
+ OBJECT-TYPE
+ OBJECT-TYPE?
+ PAIR?
+ STRING?
+ VECTOR?
+ )))
;; True if expression is a call to one of the effect-free-primitives.
(define (expression/call-to-effect-free-primitive? expression)
(and (combination? expression)
(let ((operator (combination/operator expression)))
- (and (constant? operator)
- (let ((operator-value (constant/value operator)))
- (and (memq operator-value effect-free-primitives)
- (procedure-arity-valid?
- operator-value
- (length (combination/operands expression)))))))))
+ (and (constant? operator)
+ (let ((operator-value (constant/value operator)))
+ (and (memq operator-value effect-free-primitives)
+ (procedure-arity-valid?
+ operator-value
+ (length (combination/operands expression)))))))))
;; True if expression is a call to NOT.
;; Used in conditional simplification.
(define (expression/call-to-not? expression)
(and (combination? expression)
(let ((operator (combination/operator expression)))
- (and (constant? operator)
- (let ((operator-value (constant/value operator)))
- (and (eq? operator-value (ucode-primitive not))
- (procedure-arity-valid?
- operator-value
- (length (combination/operands expression)))))))))
+ (and (constant? operator)
+ (let ((operator-value (constant/value operator)))
+ (and (eq? operator-value (ucode-primitive not))
+ (procedure-arity-valid?
+ operator-value
+ (length (combination/operands expression)))))))))
(define (expression/constant-eq? expression value)
(cond ((constant? expression) (eq? (constant/value expression) value))
- ((declaration? expression)
- (expression/constant-eq? (declaration/expression expression) value))
- (else #f)))
+ ((declaration? expression)
+ (expression/constant-eq? (declaration/expression expression) value))
+ (else #f)))
(define-integrable (global-ref/make name)
(access/make #f
- #f
- (constant/make #f system-global-environment)
- name))
+ #f
+ (constant/make #f system-global-environment)
+ name))
(define (global-ref? object)
(and (access? object)
(define (foldable-combination? operator operands)
(and (constant? operator)
(let ((operator-value (constant/value operator)))
- (and (primitive-procedure? operator-value)
- (procedure-arity-valid? operator-value (length operands))
- (memq operator-value combination/constant-folding-operators)))
- ;; Check that the arguments are constant.
+ (and (primitive-procedure? operator-value)
+ (procedure-arity-valid? operator-value (length operands))
+ (memq operator-value combination/constant-folding-operators)))
+ ;; Check that the arguments are constant.
(for-all? operands constant?)))
;; An operator is reducable if we can safely rewrite its argument list.
;; if there are declarations we don't understand, we
;; should leave things alone.
(for-all? (declarations/original
- (block/declarations (procedure/block operator)))
- declarations/known?)
+ (block/declarations (procedure/block operator)))
+ declarations/known?)
;; Unintegrated optionals are tricky and rare. Punt.
(for-all? (procedure/optional operator) variable/integrated)
;; Unintegrated rest arguments are tricky and rare. Punt.
(let ((rest-arg (procedure/rest operator)))
- (or (not rest-arg) (variable/integrated rest-arg)))))
+ (or (not rest-arg) (variable/integrated rest-arg)))))
(define (combination/make expression block operator operands)
(cond ((and (foldable-combination? operator operands)
- (noisy-test sf:enable-constant-folding? "Fold constant"))
- (combination/fold-constant expression
- (constant/value operator)
- (map constant/value operands)))
-
- ((and (reducable-operator? operator)
- (noisy-test sf:enable-argument-deletion? "Delete argument"))
- (call-with-values (lambda () (partition-operands operator operands))
- (lambda (new-argument-list new-operand-list other-operands)
- ;; The new-argument-list has the remaining arguments
- ;; after reduction. The new-operand-list is the remaining
- ;; operands after reduction. The other-operands are a
- ;; list of operands that must be evaluated (for effect)
- ;; but whose value is discarded.
- (let ((result-body
- (if (or (pair? new-argument-list)
- ;; need to avoid things like this
- ;; (foo bar (let () (define (baz) ..) ..))
- ;; optimizing into
- ;; (foo bar (define (baz) ..) ..)
- (open-block? (procedure/body operator)))
- (combination/%make
- (and expression (object/scode expression))
- block
- (procedure/make
- (procedure/scode operator)
- (procedure/block operator)
- (procedure/name operator)
- new-argument-list
- '()
- #f
- (procedure/body operator))
- new-operand-list)
- (procedure/body operator))))
- (if (null? other-operands)
- result-body
- (sequence/make
- (and expression (object/scode expression))
- (append other-operands (list result-body))))))))
- (else
- (combination/%make (and expression (object/scode expression)) block operator operands))))
+ (noisy-test sf:enable-constant-folding? "Fold constant"))
+ (combination/fold-constant expression
+ (constant/value operator)
+ (map constant/value operands)))
+
+ ((and (reducable-operator? operator)
+ (noisy-test sf:enable-argument-deletion? "Delete argument"))
+ (call-with-values (lambda () (partition-operands operator operands))
+ (lambda (new-argument-list new-operand-list other-operands)
+ ;; The new-argument-list has the remaining arguments
+ ;; after reduction. The new-operand-list is the remaining
+ ;; operands after reduction. The other-operands are a
+ ;; list of operands that must be evaluated (for effect)
+ ;; but whose value is discarded.
+ (let ((result-body
+ (if (or (pair? new-argument-list)
+ ;; need to avoid things like this
+ ;; (foo bar (let () (define (baz) ..) ..))
+ ;; optimizing into
+ ;; (foo bar (define (baz) ..) ..)
+ (open-block? (procedure/body operator)))
+ (combination/%make
+ (and expression (object/scode expression))
+ block
+ (procedure/make
+ (procedure/scode operator)
+ (procedure/block operator)
+ (procedure/name operator)
+ new-argument-list
+ '()
+ #f
+ (procedure/body operator))
+ new-operand-list)
+ (procedure/body operator))))
+ (if (null? other-operands)
+ result-body
+ (sequence/make
+ (and expression (object/scode expression))
+ (append other-operands (list result-body))))))))
+ (else
+ (combination/%make (and expression (object/scode expression)) block operator operands))))
(define (combination/fold-constant expression operator operands)
(let ((result (apply operator operands)))
(if (not (eq? sf:enable-constant-folding? #t))
(with-notification
(lambda (port)
- (display "Folding (" port)
- (display operator port)
- (for-each (lambda (operand) (display " " port) (write operand port)) operands)
- (display ") => " port)
- (write result port))))
+ (display "Folding (" port)
+ (display operator port)
+ (for-each (lambda (operand) (display " " port) (write operand port)) operands)
+ (display ") => " port)
+ (write result port))))
(constant/make (and expression (object/scode expression)) result)))
(define-integrable (partition-operands operator operands)
(let ((free-in-body (expression/free-variables (procedure/body operator))))
- (let loop ((parameters (append (procedure/required operator)
- (procedure/optional operator)))
- (operands operands)
- (required-parameters '())
- (referenced-operands '())
- (unreferenced-operands '()))
+ (let loop ((parameters (append (procedure/required operator)
+ (procedure/optional operator)))
+ (operands operands)
+ (required-parameters '())
+ (referenced-operands '())
+ (unreferenced-operands '()))
(cond ((null? parameters)
- (if (or (procedure/rest operator) (null? operands))
- (values (reverse required-parameters) ; preserve order
- (reverse referenced-operands)
- (if (or (null? operands)
- (variable/integrated (procedure/rest operator)))
- unreferenced-operands
- (append operands unreferenced-operands)))
- (error "Argument mismatch" operands)))
- ((null? operands)
- (error "Argument mismatch" parameters))
- (else
- (let ((this-parameter (car parameters))
- (this-operand (car operands)))
- (cond ((memq this-parameter free-in-body)
- (loop (cdr parameters)
- (cdr operands)
- (cons this-parameter required-parameters)
- (cons this-operand referenced-operands)
- unreferenced-operands))
- ((variable/integrated this-parameter)
- (loop (cdr parameters)
- (cdr operands)
- required-parameters
- referenced-operands
- unreferenced-operands))
- (else
- (loop (cdr parameters)
- (cdr operands)
- required-parameters
- referenced-operands
- (cons this-operand
- unreferenced-operands))))))))))
+ (if (or (procedure/rest operator) (null? operands))
+ (values (reverse required-parameters) ; preserve order
+ (reverse referenced-operands)
+ (if (or (null? operands)
+ (variable/integrated (procedure/rest operator)))
+ unreferenced-operands
+ (append operands unreferenced-operands)))
+ (error "Argument mismatch" operands)))
+ ((null? operands)
+ (error "Argument mismatch" parameters))
+ (else
+ (let ((this-parameter (car parameters))
+ (this-operand (car operands)))
+ (cond ((memq this-parameter free-in-body)
+ (loop (cdr parameters)
+ (cdr operands)
+ (cons this-parameter required-parameters)
+ (cons this-operand referenced-operands)
+ unreferenced-operands))
+ ((variable/integrated this-parameter)
+ (loop (cdr parameters)
+ (cdr operands)
+ required-parameters
+ referenced-operands
+ unreferenced-operands))
+ (else
+ (loop (cdr parameters)
+ (cdr operands)
+ required-parameters
+ referenced-operands
+ (cons this-operand
+ unreferenced-operands))))))))))
;;; Sequence
(define (sequence/make scode actions)
(define (sequence/collect-actions collected actions)
(fold-left (lambda (reversed action)
- (if (sequence? action)
- (sequence/collect-actions reversed (sequence/actions action))
- (cons action reversed)))
- collected
- actions))
+ (if (sequence? action)
+ (sequence/collect-actions reversed (sequence/actions action))
+ (cons action reversed)))
+ collected
+ actions))
(let ((filtered-actions
- (fold-left (lambda (filtered action)
- (if (expression/effect-free? action)
- (if (null? filtered)
- (list action)
- filtered)
- (cons action filtered)))
- '()
- (sequence/collect-actions '() actions))))
+ (fold-left (lambda (filtered action)
+ (if (expression/effect-free? action)
+ (if (null? filtered)
+ (list action)
+ filtered)
+ (cons action filtered)))
+ '()
+ (sequence/collect-actions '() actions))))
(if (null? (cdr filtered-actions))
- (car filtered-actions)
- (sequence/%make scode filtered-actions))))
+ (car filtered-actions)
+ (sequence/%make scode filtered-actions))))
;; Done specially so we can tweak the print method.
;; This makes debugging an awful lot easier.
(define-structure (reference
- (type vector)
- (named reference/enumerand)
- (type-descriptor rtd:reference)
- (conc-name reference/)
- (constructor reference/make)
- (print-procedure
- (standard-unparser-method
- 'reference
- (lambda (ref port)
- (write-string " to " port)
- (write (variable/name (reference/variable ref)) port)))))
+ (type vector)
+ (named reference/enumerand)
+ (type-descriptor rtd:reference)
+ (conc-name reference/)
+ (constructor reference/make)
+ (print-procedure
+ (standard-unparser-method
+ 'reference
+ (lambda (ref port)
+ (write-string " to " port)
+ (write (variable/name (reference/variable ref)) port)))))
(scode #f read-only #t)
block
variable)
(lambda (form environment)
environment
(let ((name (cadr form))
- (tester (caddr form))
- (setter (cadddr form)))
+ (tester (caddr form))
+ (setter (cadddr form)))
`(BEGIN
- (DEFINE (,tester VARIABLE)
- (MEMQ ',name (VARIABLE/FLAGS VARIABLE)))
- (DEFINE (,setter VARIABLE)
- (IF (NOT (MEMQ ',name (VARIABLE/FLAGS VARIABLE)))
- (SET-VARIABLE/FLAGS!
- VARIABLE
- (CONS ',name (VARIABLE/FLAGS VARIABLE))))))))))
+ (DEFINE (,tester VARIABLE)
+ (MEMQ ',name (VARIABLE/FLAGS VARIABLE)))
+ (DEFINE (,setter VARIABLE)
+ (IF (NOT (MEMQ ',name (VARIABLE/FLAGS VARIABLE)))
+ (SET-VARIABLE/FLAGS!
+ VARIABLE
+ (CONS ',name (VARIABLE/FLAGS VARIABLE))))))))))
(define-flag SIDE-EFFECTED variable/side-effected variable/side-effect!)
(define-flag REFERENCED variable/referenced variable/reference!)
(define (expression/make-method-definer dispatch-vector)
(lambda (type-name method)
(vector-set! dispatch-vector
- (enumeration/name->index enumeration/expression type-name)
- method)))
+ (enumeration/name->index enumeration/expression type-name)
+ method)))
(define-integrable (expression/method dispatch-vector expression)
(vector-ref dispatch-vector (enumerand/index (object/enumerand expression))))
(define-integrable (name->method dispatch-vector name)
;; Useful for debugging
(vector-ref dispatch-vector
- (enumeration/name->index enumeration/expression name)))
+ (enumeration/name->index enumeration/expression name)))
;;; Integration Info
(define integration-info-tag
(define (noisy-test switch text)
(and switch
(cond ((eq? switch 'warn)
- (warn "Not performing possible action:" text)
- #f)
- ((not (eq? switch #t))
- (with-notification
- (lambda (port) (write-string text port)))
- #t)
- (else #t))))
+ (warn "Not performing possible action:" text)
+ #f)
+ ((not (eq? switch #t))
+ (with-notification
+ (lambda (port) (write-string text port)))
+ #t)
+ (else #t))))
(define-package (scode-optimizer)
(files "pthmap"
- "object"
- "emodel"
- "gconst"
- "usicon"
- "tables")
+ "object"
+ "emodel"
+ "gconst"
+ "usicon"
+ "tables")
(parent ())
(import (runtime scode-combinator)
- combination/constant-folding-operators)
+ combination/constant-folding-operators)
(export ()
- sf:enable-argument-deletion?
- sf:enable-constant-folding?))
+ sf:enable-argument-deletion?
+ sf:enable-constant-folding?))
(define-package (scode-optimizer global-imports)
(files "gimprt")
(parent ())
(export (scode-optimizer)
- scode-assignment?
- scode-open-block?
- scode-sequence?))
+ scode-assignment?
+ scode-open-block?
+ scode-sequence?))
(define-package (scode-optimizer top-level)
(files "toplev")
(parent (scode-optimizer))
(export ()
- sf
- sf/default-declarations
- sf/default-syntax-table
- sf/pathname-defaulting
- sf/set-usual-integrations-default-deletions!
- sf/top-level-definitions
- sf/usual-integrations-default-deletions
- sf:noisy?
- syntax&integrate)
+ sf
+ sf/default-declarations
+ sf/default-syntax-table
+ sf/pathname-defaulting
+ sf/set-usual-integrations-default-deletions!
+ sf/top-level-definitions
+ sf/usual-integrations-default-deletions
+ sf:noisy?
+ syntax&integrate)
(export (scode-optimizer)
- integrate/procedure
- integrate/file
- integrate/sexp
- integrate/scode
- read-externs-file))
+ integrate/procedure
+ integrate/file
+ integrate/sexp
+ integrate/scode
+ read-externs-file))
(define-package (scode-optimizer transform)
(files "xform")
(parent (scode-optimizer))
(export (scode-optimizer)
- transform/top-level
- transform/recursive))
+ transform/top-level
+ transform/recursive))
(define-package (scode-optimizer integrate)
(files "subst")
(parent (scode-optimizer))
(export ()
- sf:display-top-level-procedure-names?
- sf:enable-conditional-folding?
- sf:enable-disjunction-folding?
- sf:enable-elide-double-negatives?
- sf:enable-safe-integration?)
+ sf:display-top-level-procedure-names?
+ sf:enable-conditional-folding?
+ sf:enable-disjunction-folding?
+ sf:enable-elide-double-negatives?
+ sf:enable-safe-integration?)
(export (scode-optimizer)
- integrate/top-level
- integrate/get-top-level-block
- reassign
- variable/final-value))
+ integrate/top-level
+ integrate/get-top-level-block
+ reassign
+ variable/final-value))
(define-package (scode-optimizer cgen)
(files "cgen")
(parent (scode-optimizer))
(export (scode-optimizer)
- *sf-associate*
- cgen/external
- pp-expression)
+ *sf-associate*
+ cgen/external
+ pp-expression)
(export (scode-optimizer expansion)
- cgen/external-with-declarations))
+ cgen/external-with-declarations))
(define-package (scode-optimizer expansion)
(files "usiexp" "reduct")
(parent (scode-optimizer))
(export (scode-optimizer)
- reducer/make
- replacement/make
- usual-integrations/expansion-names
- usual-integrations/expansion-values
- usual-integrations/expansion-alist)
+ reducer/make
+ replacement/make
+ usual-integrations/expansion-names
+ usual-integrations/expansion-values
+ usual-integrations/expansion-alist)
(export (scode-optimizer declarations)
- expander-evaluation-environment))
+ expander-evaluation-environment))
(define-package (scode-optimizer declarations)
(files "pardec")
(parent (scode-optimizer))
(export (scode-optimizer)
- declarations/bind
- declarations/known?
- declarations/make-null
- declarations/map
- declarations/original
- declarations/parse
- guarantee-known-declaration
- operations->external))
+ declarations/bind
+ declarations/known?
+ declarations/make-null
+ declarations/map
+ declarations/original
+ declarations/parse
+ guarantee-known-declaration
+ operations->external))
(define-package (scode-optimizer copy)
(files "copy")
(parent (scode-optimizer))
(export (scode-optimizer)
- copy/expression/intern
- copy/expression/extern))
+ copy/expression/intern
+ copy/expression/extern))
(define-package (scode-optimizer analyze)
(files "analyze")
(parent (scode-optimizer))
(export (scode-optimizer)
- expression/always-false?
- expression/boolean?
- expression/effect-free?
- expression/free-variable?
- expression/free-variable-info
- expression/free-variables
- expression/never-false?
- expression/pure-false?
- expression/pure-true?
- expression/size))
+ expression/always-false?
+ expression/boolean?
+ expression/effect-free?
+ expression/free-variable?
+ expression/free-variable-info
+ expression/free-variables
+ expression/never-false?
+ expression/pure-false?
+ expression/pure-true?
+ expression/size))
(define-package (scode-optimizer change-type)
(files "chtype")
(parent (scode-optimizer))
(export (scode-optimizer)
- change-type/block
- change-type/expression))
+ change-type/block
+ change-type/expression))
(define-package (scode-optimizer build-utilities)
(files "butils")
(parent ())
(export ()
- compile-directory
- compile-directory?
- sf-conditionally
- sf-directory
- sf-directory?))
\ No newline at end of file
+ compile-directory
+ compile-directory?
+ sf-conditionally
+ sf-directory
+ sf-directory?))
\ No newline at end of file
;;; package: (scode-optimizer integrate)
(declare (usual-integrations)
- (integrate-external "object"))
+ (integrate-external "object"))
\f
(define *top-level-block*)
(define (ignored-variable-warning name)
(warn (string-append "Variable \""
- (symbol->string name)
- "\" was declared IGNORE, but used anyway.")
- name *current-block-names*))
+ (symbol->string name)
+ "\" was declared IGNORE, but used anyway.")
+ name *current-block-names*))
(define (integrate/top-level block expression)
(integrate/top-level* (object/scode expression) block expression))
(define (integrate/top-level* scode block expression)
(fluid-let ((*top-level-block* block)
- (*current-block-names* '()))
+ (*current-block-names* '()))
(call-with-values
- (lambda ()
- (let ((operations (operations/make))
- (environment (environment/make)))
- (if (open-block? expression)
- (integrate/open-block operations environment expression)
- (let ((operations
- (declarations/bind operations
- (block/declarations block))))
- (values operations
- environment
- (integrate/expression operations
- environment
- expression))))))
+ (lambda ()
+ (let ((operations (operations/make))
+ (environment (environment/make)))
+ (if (open-block? expression)
+ (integrate/open-block operations environment expression)
+ (let ((operations
+ (declarations/bind operations
+ (block/declarations block))))
+ (values operations
+ environment
+ (integrate/expression operations
+ environment
+ expression))))))
(lambda (operations environment expression)
(values operations environment
- (quotation/make scode
- block
- expression))))))
+ (quotation/make scode
+ block
+ expression))))))
(define (integrate/expressions operations environment expressions)
(map (lambda (expression)
- (integrate/expression operations environment expression))
+ (integrate/expression operations environment expression))
expressions))
(define (integrate/actions operations environment actions)
(let ((action (car actions)))
(if (null? (cdr actions))
- (list (if (eq? action open-block/value-marker)
- action
- (integrate/expression operations environment action)))
- (cons (cond ((eq? action open-block/value-marker)
- action)
- (else
- (integrate/expression operations environment action)))
- (integrate/actions operations environment (cdr actions))))))
+ (list (if (eq? action open-block/value-marker)
+ action
+ (integrate/expression operations environment action)))
+ (cons (cond ((eq? action open-block/value-marker)
+ action)
+ (else
+ (integrate/expression operations environment action)))
+ (integrate/actions operations environment (cdr actions))))))
(define (integrate/expression operations environment expression)
((expression/method dispatch-vector expression)
(define-method/integrate 'ACCESS
(lambda (operations environment expression)
(let ((environment* (integrate/expression operations environment
- (access/environment expression)))
- (name (access/name expression)))
+ (access/environment expression)))
+ (name (access/name expression)))
(define (dont-integrate)
- (access/make (access/scode expression)
- (access/block expression)
- environment* name))
+ (access/make (access/scode expression)
+ (access/block expression)
+ environment* name))
(if (not (constant/system-global-environment? environment*))
- (dont-integrate)
- (operations/lookup-global
- operations name
- (lambda (operation info)
- (case operation
- ((#F EXPAND INTEGRATE-OPERATOR) (dont-integrate))
-
- ((IGNORE)
- (ignored-variable-warning name)
- (dont-integrate))
-
- ((INTEGRATE)
- (reassign name (copy/expression/intern
- (access/block expression)
- (integration-info/expression info))))
-
- (else
- (error "Unknown operation" operation))))
- dont-integrate)))))
+ (dont-integrate)
+ (operations/lookup-global
+ operations name
+ (lambda (operation info)
+ (case operation
+ ((#F EXPAND INTEGRATE-OPERATOR) (dont-integrate))
+
+ ((IGNORE)
+ (ignored-variable-warning name)
+ (dont-integrate))
+
+ ((INTEGRATE)
+ (reassign name (copy/expression/intern
+ (access/block expression)
+ (integration-info/expression info))))
+
+ (else
+ (error "Unknown operation" operation))))
+ dont-integrate)))))
;;;; ASSIGNMENT
(define-method/integrate 'ASSIGNMENT
(let ((variable (assignment/variable assignment)))
(operations/lookup operations variable
(lambda (operation info)
- info ;ignore
- (case operation
- ((IGNORE)
- (ignored-variable-warning (variable/name variable)))
- ((EXPAND INTEGRATE INTEGRATE-OPERATOR)
- (warn "Attempt to assign integrated name"
- (variable/name variable)))
- (else (error "Unknown operation" operation))))
+ info ;ignore
+ (case operation
+ ((IGNORE)
+ (ignored-variable-warning (variable/name variable)))
+ ((EXPAND INTEGRATE INTEGRATE-OPERATOR)
+ (warn "Attempt to assign integrated name"
+ (variable/name variable)))
+ (else (error "Unknown operation" operation))))
false-procedure)
(variable/reference! variable)
(assignment/make (assignment/scode assignment)
- (assignment/block assignment)
- variable
- (integrate/expression operations
- environment
- (assignment/value assignment))))))
+ (assignment/block assignment)
+ variable
+ (integrate/expression operations
+ environment
+ (assignment/value assignment))))))
;;;; COMBINATION
(define-method/integrate 'COMBINATION
(combination/block combination)
(combination/operator combination)
(integrate/expressions operations
- environment
- (combination/operands combination)))))
+ environment
+ (combination/operands combination)))))
;;;; CONDITIONAL
(define-method/integrate 'CONDITIONAL
(lambda (operations environment expression)
(integrate/conditional operations environment expression
- (integrate/expression
- operations environment
- (conditional/predicate expression))
- (conditional/consequent expression)
- (conditional/alternative expression))))
+ (integrate/expression
+ operations environment
+ (conditional/predicate expression))
+ (conditional/consequent expression)
+ (conditional/alternative expression))))
(define sf:enable-conditional-folding? #t)
(define (integrate/conditional operations environment expression
- integrated-predicate
- consequent
- alternative)
+ integrated-predicate
+ consequent
+ alternative)
(cond ((expression/call-to-not? integrated-predicate)
- ;; (if (not <e1>) <e2> <e3>) => (if <e1> <e3> <e2>)
- (integrate/conditional
- operations environment expression
- (first (combination/operands integrated-predicate))
- alternative consequent))
-
- ((sequence? integrated-predicate)
- (sequence/make
- (and expression (object/scode expression))
- (append (except-last-pair (sequence/actions integrated-predicate))
- (list (integrate/conditional
- operations environment #f
- (last (sequence/actions integrated-predicate))
- consequent
- alternative)))))
-
- ((and (expression/never-false? integrated-predicate)
- (noisy-test sf:enable-conditional-folding?
- "Fold constant true conditional"))
- (sequence/make
- (and expression (conditional/scode expression))
- (list integrated-predicate
- (integrate/expression operations environment consequent))))
-
- ((and (expression/always-false? integrated-predicate)
- (noisy-test sf:enable-conditional-folding?
- "Fold constant false conditional"))
- (sequence/make
- (and expression (conditional/scode expression))
- (list integrated-predicate
- (integrate/expression operations environment alternative))))
-
- (else
- (conditional/make (and expression (conditional/scode expression))
- integrated-predicate
- (integrate/expression operations environment consequent)
- (integrate/expression operations environment alternative)))))
+ ;; (if (not <e1>) <e2> <e3>) => (if <e1> <e3> <e2>)
+ (integrate/conditional
+ operations environment expression
+ (first (combination/operands integrated-predicate))
+ alternative consequent))
+
+ ((sequence? integrated-predicate)
+ (sequence/make
+ (and expression (object/scode expression))
+ (append (except-last-pair (sequence/actions integrated-predicate))
+ (list (integrate/conditional
+ operations environment #f
+ (last (sequence/actions integrated-predicate))
+ consequent
+ alternative)))))
+
+ ((and (expression/never-false? integrated-predicate)
+ (noisy-test sf:enable-conditional-folding?
+ "Fold constant true conditional"))
+ (sequence/make
+ (and expression (conditional/scode expression))
+ (list integrated-predicate
+ (integrate/expression operations environment consequent))))
+
+ ((and (expression/always-false? integrated-predicate)
+ (noisy-test sf:enable-conditional-folding?
+ "Fold constant false conditional"))
+ (sequence/make
+ (and expression (conditional/scode expression))
+ (list integrated-predicate
+ (integrate/expression operations environment alternative))))
+
+ (else
+ (conditional/make (and expression (conditional/scode expression))
+ integrated-predicate
+ (integrate/expression operations environment consequent)
+ (integrate/expression operations environment alternative)))))
;;; CONSTANT
(define-method/integrate 'CONSTANT
(define-method/integrate 'DECLARATION
(lambda (operations environment declaration)
(let ((answer
- (integrate/expression
- (declarations/bind operations
- (declaration/declarations declaration))
- environment (declaration/expression declaration))))
+ (integrate/expression
+ (declarations/bind operations
+ (declaration/declarations declaration))
+ environment (declaration/expression declaration))))
(if (constant? answer)
- answer
- (declaration/make
- (declaration/scode declaration)
- (declaration/declarations declaration)
- answer)))))
+ answer
+ (declaration/make
+ (declaration/scode declaration)
+ (declaration/declarations declaration)
+ answer)))))
;;; DELAY
(define-method/integrate 'DELAY
(delay/make
(delay/scode expression)
(integrate/expression operations environment
- (delay/expression expression)))))
+ (delay/expression expression)))))
;;; DISJUNCTION
(define sf:enable-disjunction-folding? #t)
(define (integrate/disjunction operations environment expression
- integrated-predicate alternative)
+ integrated-predicate alternative)
(cond ((expression/call-to-not? integrated-predicate)
- ;; (or (not e1) e2) => (if e1 e2 #t)
- (integrate/conditional
- operations environment expression
- (first (combination/operands integrated-predicate))
- alternative
- (constant/make #f #t)))
-
- ((and (expression/never-false? integrated-predicate)
- (noisy-test sf:enable-disjunction-folding?
- "Fold constant true disjunction"))
- ;; (or <exp1> <exp2>) => <exp1> if <exp1> is never false
- integrated-predicate)
-
- ((and (expression/always-false? integrated-predicate)
- (noisy-test sf:enable-disjunction-folding?
- "Fold constant false disjunction"))
- ;; (or <exp1> <exp2>)
- ;; => (begin <exp1> <exp2>) if <exp1> is always false
- (sequence/make (and expression (object/scode expression))
- (list integrated-predicate
- (integrate/expression
- operations environment alternative))))
-
- ((sequence? integrated-predicate)
- (sequence/make
- (and expression (object/scode expression))
- (append (except-last-pair (sequence/actions integrated-predicate))
- (list (integrate/disjunction
- operations environment #f
- (last (sequence/actions integrated-predicate))
- alternative)))))
-
- (else
- (disjunction/make (and expression (object/scode expression))
- integrated-predicate
- (integrate/expression
- operations
- environment alternative)))))
+ ;; (or (not e1) e2) => (if e1 e2 #t)
+ (integrate/conditional
+ operations environment expression
+ (first (combination/operands integrated-predicate))
+ alternative
+ (constant/make #f #t)))
+
+ ((and (expression/never-false? integrated-predicate)
+ (noisy-test sf:enable-disjunction-folding?
+ "Fold constant true disjunction"))
+ ;; (or <exp1> <exp2>) => <exp1> if <exp1> is never false
+ integrated-predicate)
+
+ ((and (expression/always-false? integrated-predicate)
+ (noisy-test sf:enable-disjunction-folding?
+ "Fold constant false disjunction"))
+ ;; (or <exp1> <exp2>)
+ ;; => (begin <exp1> <exp2>) if <exp1> is always false
+ (sequence/make (and expression (object/scode expression))
+ (list integrated-predicate
+ (integrate/expression
+ operations environment alternative))))
+
+ ((sequence? integrated-predicate)
+ (sequence/make
+ (and expression (object/scode expression))
+ (append (except-last-pair (sequence/actions integrated-predicate))
+ (list (integrate/disjunction
+ operations environment #f
+ (last (sequence/actions integrated-predicate))
+ alternative)))))
+
+ (else
+ (disjunction/make (and expression (object/scode expression))
+ integrated-predicate
+ (integrate/expression
+ operations
+ environment alternative)))))
;;; OPEN-BLOCK
(define-method/integrate 'OPEN-BLOCK
(lambda (operations environment expression)
(call-with-values
- (lambda () (integrate/open-block operations environment expression))
+ (lambda () (integrate/open-block operations environment expression))
(lambda (operations environment expression)
- (declare (ignore operations environment))
- expression))))
+ (declare (ignore operations environment))
+ expression))))
;;; PROCEDURE
(define-method/integrate 'PROCEDURE
(lambda (operations environment procedure)
(integrate/procedure operations
- (simulate-unknown-application environment procedure)
- procedure)))
+ (simulate-unknown-application environment procedure)
+ procedure)))
;;;; Quotation
(define-method/integrate 'QUOTATION
(define (integrate/quotation quotation)
(call-with-values
(lambda ()
- (integrate/top-level* (quotation/scode quotation)
- (quotation/block quotation)
- (quotation/expression quotation)))
+ (integrate/top-level* (quotation/scode quotation)
+ (quotation/block quotation)
+ (quotation/expression quotation)))
(lambda (operations environment expression)
- operations environment ;ignore
+ operations environment ;ignore
expression)))
;;;; Reference
(lambda (operations environment expression)
(let ((variable (reference/variable expression)))
(define (dont-integrate)
- (variable/reference! variable)
- expression)
+ (variable/reference! variable)
+ expression)
(operations/lookup
operations variable
(lambda (operation info)
- (case operation
- ((IGNORE)
- (ignored-variable-warning (variable/name variable))
- (dont-integrate))
+ (case operation
+ ((IGNORE)
+ (ignored-variable-warning (variable/name variable))
+ (dont-integrate))
- ((EXPAND INTEGRATE-OPERATOR)
- (dont-integrate))
+ ((EXPAND INTEGRATE-OPERATOR)
+ (dont-integrate))
- ((INTEGRATE)
- (let ((new-expression
- (integrate/name expression expression info environment)))
- (if new-expression
- (begin (variable/integrated! variable)
- new-expression)
- (dont-integrate))))
+ ((INTEGRATE)
+ (let ((new-expression
+ (integrate/name expression expression info environment)))
+ (if new-expression
+ (begin (variable/integrated! variable)
+ new-expression)
+ (dont-integrate))))
- (else
- (error "Unknown operation" operation))))
+ (else
+ (error "Unknown operation" operation))))
dont-integrate))))
(sequence/make
(and expression (object/scode expression))
(integrate/actions operations environment
- (sequence/actions expression)))))
+ (sequence/actions expression)))))
;;; THE-ENVIRONMENT
(define-method/integrate 'THE-ENVIRONMENT
(define (maybe-displaying-name name thunk)
(if (and sf:display-top-level-procedure-names?
- (null? *current-block-names*))
+ (null? *current-block-names*))
(with-notification
(lambda (port)
- (write-string "Integrating procedure " port)
- (write name port))
+ (write-string "Integrating procedure " port)
+ (write name port))
thunk)
(thunk)))
(define (integrate/open-block operations environment expression)
(let ((variables (open-block/variables expression))
- (block (open-block/block expression)))
+ (block (open-block/block expression)))
(let ((operations
- (declarations/bind (operations/shadow operations variables)
- (block/declarations block))))
+ (declarations/bind (operations/shadow operations variables)
+ (block/declarations block))))
(call-with-values
- (lambda ()
- (environment/recursive-bind operations
- environment
- variables
- (open-block/values expression)))
- (lambda (environment vals)
- (let ((actions
- (integrate/actions operations
- environment
- (open-block/actions expression))))
- ;; Complain about unreferenced variables.
- ;; If the block is unsafe, then it is likely that
- ;; there will be a lot of them on purpose (top level or
- ;; the-environment) so no complaining.
- (if (block/safe? (open-block/block expression))
- (for-each (lambda (variable)
- (if (variable/unreferenced? variable)
- (warn "Unreferenced defined variable:"
- (variable/name variable))))
- variables))
- (values operations
- environment
- (open-block/make
- (and expression (object/scode expression))
- block variables
- vals actions))))))))
+ (lambda ()
+ (environment/recursive-bind operations
+ environment
+ variables
+ (open-block/values expression)))
+ (lambda (environment vals)
+ (let ((actions
+ (integrate/actions operations
+ environment
+ (open-block/actions expression))))
+ ;; Complain about unreferenced variables.
+ ;; If the block is unsafe, then it is likely that
+ ;; there will be a lot of them on purpose (top level or
+ ;; the-environment) so no complaining.
+ (if (block/safe? (open-block/block expression))
+ (for-each (lambda (variable)
+ (if (variable/unreferenced? variable)
+ (warn "Unreferenced defined variable:"
+ (variable/name variable))))
+ variables))
+ (values operations
+ environment
+ (open-block/make
+ (and expression (object/scode expression))
+ block variables
+ vals actions))))))))
(define (variable/unreferenced? variable)
(and (not (variable/integrated variable))
(define (integrate/procedure operations environment procedure)
(let ((block (procedure/block procedure))
- (name (procedure/name procedure))
- (required (procedure/required procedure))
- (optional (procedure/optional procedure))
- (rest (procedure/rest procedure)))
+ (name (procedure/name procedure))
+ (required (procedure/required procedure))
+ (optional (procedure/optional procedure))
+ (rest (procedure/rest procedure)))
(maybe-displaying-name
name
(lambda ()
(fluid-let ((*current-block-names* (cons name *current-block-names*)))
- (let* ((operations (declarations/bind
- (operations/shadow
- operations
- (append required optional (if rest (list rest) '())))
- (block/declarations block)))
-
- (body (integrate/expression
- (if (block/safe? block)
- (make-additional-declarations
- operations environment
- (procedure/body procedure)
- (block/bound-variables block))
- operations)
- environment
- (procedure/body procedure))))
- ;; Possibly complain about variables bound and not
- ;; referenced.
- (if (block/safe? block)
- (for-each (lambda (variable)
- (if (variable/unreferenced? variable)
- (warn "Unreferenced bound variable:"
- (variable/name variable)
- *current-block-names*)))
- (if rest
- (append required optional (list rest))
- (append required optional))))
- (procedure/make (procedure/scode procedure)
- block
- name
- required
- optional
- rest
- body)))))))
+ (let* ((operations (declarations/bind
+ (operations/shadow
+ operations
+ (append required optional (if rest (list rest) '())))
+ (block/declarations block)))
+
+ (body (integrate/expression
+ (if (block/safe? block)
+ (make-additional-declarations
+ operations environment
+ (procedure/body procedure)
+ (block/bound-variables block))
+ operations)
+ environment
+ (procedure/body procedure))))
+ ;; Possibly complain about variables bound and not
+ ;; referenced.
+ (if (block/safe? block)
+ (for-each (lambda (variable)
+ (if (variable/unreferenced? variable)
+ (warn "Unreferenced bound variable:"
+ (variable/name variable)
+ *current-block-names*)))
+ (if rest
+ (append required optional (list rest))
+ (append required optional))))
+ (procedure/make (procedure/scode procedure)
+ block
+ name
+ required
+ optional
+ rest
+ body)))))))
(define sf:enable-safe-integration? #t)
(define (make-additional-declarations operations environment body variables)
(fold-left (lambda (operations variable)
- (make-additional-declaration operations environment body variable))
- operations
- variables))
+ (make-additional-declaration operations environment body variable))
+ operations
+ variables))
(define (make-additional-declaration operations environment body variable)
;; Possibly augment operations with an appropriate declaration.
;; Already a declaration, don't override it.
(constant-procedure operations)
(lambda ()
- ;; No operations on this variable, check if it has
- ;; a value
- (environment/lookup
- environment variable
- (lambda (value)
- ;; it has a value, see if we should integrate it
- (make-additional-declaration-with-value operations body variable value))
- ;; No value
- (constant-procedure operations)
- ;; No binding
- (constant-procedure operations))))))
+ ;; No operations on this variable, check if it has
+ ;; a value
+ (environment/lookup
+ environment variable
+ (lambda (value)
+ ;; it has a value, see if we should integrate it
+ (make-additional-declaration-with-value operations body variable value))
+ ;; No value
+ (constant-procedure operations)
+ ;; No binding
+ (constant-procedure operations))))))
(define (make-additional-declaration-with-value operations body variable value)
(cond ((and (or (and (access? value) (global-ref? value))
- (constant? value)
- (and (reference? value)
- (not (variable/side-effected (reference/variable value)))
- (block/safe? (variable/block (reference/variable value)))))
- (noisy-test sf:enable-safe-integration? "Safe declarations"))
- (operations/bind operations 'INTEGRATE variable
- (make-integration-info value)))
- ((procedure? value)
- (let ((info (expression/free-variable-info body variable)))
- ;; Avoid exponential code explosion.
- ;; The *parser code gets out of control if you don't limit this.
- (if (and (fix:zero? (cdr info)) ; No argument references
- (or (fix:= (car info) 1) ; Exactly one operator use
- (and (fix:> (car info) 1)
- (< (* (expression/size value) (car info)) 500)))
- (noisy-test sf:enable-safe-integration? "Safe declarations"))
- (operations/bind operations 'INTEGRATE-OPERATOR variable
- (make-integration-info value))
- operations)))
- (else operations)))
+ (constant? value)
+ (and (reference? value)
+ (not (variable/side-effected (reference/variable value)))
+ (block/safe? (variable/block (reference/variable value)))))
+ (noisy-test sf:enable-safe-integration? "Safe declarations"))
+ (operations/bind operations 'INTEGRATE variable
+ (make-integration-info value)))
+ ((procedure? value)
+ (let ((info (expression/free-variable-info body variable)))
+ ;; Avoid exponential code explosion.
+ ;; The *parser code gets out of control if you don't limit this.
+ (if (and (fix:zero? (cdr info)) ; No argument references
+ (or (fix:= (car info) 1) ; Exactly one operator use
+ (and (fix:> (car info) 1)
+ (< (* (expression/size value) (car info)) 500)))
+ (noisy-test sf:enable-safe-integration? "Safe declarations"))
+ (operations/bind operations 'INTEGRATE-OPERATOR variable
+ (make-integration-info value))
+ operations)))
+ (else operations)))
\f
;;; INTEGRATE-COMBINATION
(expression/make-method-definer integrate-combination-dispatch-vector))
(define (integrate/combination expression operations environment
- block operator operands)
+ block operator operands)
((expression/method integrate-combination-dispatch-vector operator)
expression operations environment block operator operands))
(define-method/integrate-combination 'ACCESS
(lambda (expression operations environment block operator operands)
(integrate/access-operator expression operations environment
- block operator operands)))
+ block operator operands)))
(define (integrate/access-operator expression operations environment block operator operands)
(let ((name (access/name operator))
- (environment*
- (integrate/expression operations environment (access/environment operator))))
+ (environment*
+ (integrate/expression operations environment (access/environment operator))))
(define (dont-integrate)
(combination/make
expression block
(access/make (access/scode operator)
- (access/block operator)
- environment* name) operands))
+ (access/block operator)
+ environment* name) operands))
(if (not (constant/system-global-environment? environment*))
- (dont-integrate)
- (operations/lookup-global
- operations name
- (lambda (operation info)
- (case operation
- ((#F) (dont-integrate))
-
- ((EXPAND)
- (cond ((info expression operands (reference/block operator))
- => (lambda (new-expression)
- (integrate/expression operations environment new-expression)))
- (else (dont-integrate))))
-
- ((IGNORE)
- (ignored-variable-warning (variable/name name))
- (dont-integrate))
-
- ((INTEGRATE INTEGRATE-OPERATOR)
- (let ((new-operator
- (reassign operator
- (copy/expression/intern block (integration-info/expression info)))))
- (integrate/combination expression operations environment block new-operator operands)))
-
- (else
- (error "unknown operation" operation))))
- dont-integrate))))
+ (dont-integrate)
+ (operations/lookup-global
+ operations name
+ (lambda (operation info)
+ (case operation
+ ((#F) (dont-integrate))
+
+ ((EXPAND)
+ (cond ((info expression operands (reference/block operator))
+ => (lambda (new-expression)
+ (integrate/expression operations environment new-expression)))
+ (else (dont-integrate))))
+
+ ((IGNORE)
+ (ignored-variable-warning (variable/name name))
+ (dont-integrate))
+
+ ((INTEGRATE INTEGRATE-OPERATOR)
+ (let ((new-operator
+ (reassign operator
+ (copy/expression/intern block (integration-info/expression info)))))
+ (integrate/combination expression operations environment block new-operator operands)))
+
+ (else
+ (error "unknown operation" operation))))
+ dont-integrate))))
;;; assignment-operator
(define-method/integrate-combination 'ASSIGNMENT
;; We don't try to make sense of this, we just
;; build the code and let the runtime raise an error.
(combination/make expression
- block
- (integrate/expression operations environment operator)
- operands)))
+ block
+ (integrate/expression operations environment operator)
+ operands)))
;;; combination-operator
(define-method/integrate-combination 'COMBINATION
(lambda (expression operations environment block operator operands)
;; Elide a double negative only if it doesn't change the type of the answer.
(cond ((and (expression/constant-eq? operator (ucode-primitive not))
- (length=? operands 1)
- (expression/call-to-not? (first operands))
- (expression/boolean?
- (first (combination/operands (first operands))))
- (noisy-test sf:enable-elide-double-negatives?
- "Elide double negative"))
- (first (combination/operands (first operands))))
-
- ((primitive-procedure? (constant/value operator))
- (let ((operands*
- (and (eq? (constant/value operator) (ucode-primitive apply))
- (integrate/hack-apply? operands))))
- (if operands*
- (integrate/combination expression operations environment
- block (car operands*) (cdr operands*))
- (integrate/primitive-operator expression operations environment
- block operator operands))))
-
- (else
- (warn "Application of constant value" (constant/value operator))
- (integrate-combination/default expression operations environment
- block operator operands)))))
+ (length=? operands 1)
+ (expression/call-to-not? (first operands))
+ (expression/boolean?
+ (first (combination/operands (first operands))))
+ (noisy-test sf:enable-elide-double-negatives?
+ "Elide double negative"))
+ (first (combination/operands (first operands))))
+
+ ((primitive-procedure? (constant/value operator))
+ (let ((operands*
+ (and (eq? (constant/value operator) (ucode-primitive apply))
+ (integrate/hack-apply? operands))))
+ (if operands*
+ (integrate/combination expression operations environment
+ block (car operands*) (cdr operands*))
+ (integrate/primitive-operator expression operations environment
+ block operator operands))))
+
+ (else
+ (warn "Application of constant value" (constant/value operator))
+ (integrate-combination/default expression operations environment
+ block operator operands)))))
(define (integrate/primitive-operator expression operations environment
- block operator operands)
+ block operator operands)
(declare (ignore operations environment))
(combination/make expression block operator operands))
;; Nonsense - generate a warning.
(warn "Delayed object in operator position. This will cause a runtime error.")
(combination/make expression
- block
- (integrate/expression operations environment operator)
- operands)))
+ block
+ (integrate/expression operations environment operator)
+ operands)))
;;; disjunction-operator
(define-method/integrate-combination 'DISJUNCTION
(lambda (expression operations environment block operator operands)
(integrate-combination/default expression operations environment
- block operator operands)))
+ block operator operands)))
;;; open-block-operator
(define-method/integrate-combination 'OPEN-BLOCK
(define-method/integrate-combination 'PROCEDURE
(lambda (expression operations environment block operator operands)
(integrate-combination/default expression operations environment
- block operator operands)))
+ block operator operands)))
(define (integrate/procedure-operator operations environment
- block procedure operands)
+ block procedure operands)
(integrate/procedure operations
- (simulate-application environment block
- procedure operands)
- procedure))
+ (simulate-application environment block
+ procedure operands)
+ procedure))
;;; quotation-operator
(define-method/integrate-combination 'QUOTATION
(lambda (expression operations environment block operator operands)
- (integrate-combination/default expression operations environment
- block operator operands)))
+ (integrate-combination/default expression operations environment
+ block operator operands)))
;;; reference-operator
(define-method/integrate-combination 'REFERENCE
(lambda (expression operations environment block operator operands)
(integrate/reference-operator expression operations environment
- block operator operands)))
+ block operator operands)))
(define (integrate/reference-operator expression operations environment
- block operator operands)
+ block operator operands)
(let ((variable (reference/variable operator)))
(letrec ((mark-integrated!
- (lambda ()
- (variable/integrated! variable)))
- (integration-failure
- (lambda ()
- (variable/reference! variable)
- (combination/make expression block
- operator operands)))
- (integration-success
- (lambda (operator)
- (mark-integrated!)
- (integrate/combination expression operations environment
- block operator operands))))
+ (lambda ()
+ (variable/integrated! variable)))
+ (integration-failure
+ (lambda ()
+ (variable/reference! variable)
+ (combination/make expression block
+ operator operands)))
+ (integration-success
+ (lambda (operator)
+ (mark-integrated!)
+ (integrate/combination expression operations environment
+ block operator operands))))
(operations/lookup operations variable
- (lambda (operation info)
- (case operation
- ((#F) (integration-failure))
-
- ((EXPAND)
- (let ((new-expression (info expression operands (reference/block operator))))
- (if new-expression
- (begin
- (mark-integrated!)
- (integrate/expression operations environment new-expression))
- (integration-failure))))
-
- ((IGNORE)
- (ignored-variable-warning (variable/name variable))
- (integration-failure))
-
- ((INTEGRATE INTEGRATE-OPERATOR)
- (let ((new-expression (integrate/name expression
- operator info environment)))
- (if new-expression
- (integration-success new-expression)
- (integration-failure))))
-
- (else
- (error "Unknown operation" operation))))
- (lambda ()
- (integration-failure))))))
+ (lambda (operation info)
+ (case operation
+ ((#F) (integration-failure))
+
+ ((EXPAND)
+ (let ((new-expression (info expression operands (reference/block operator))))
+ (if new-expression
+ (begin
+ (mark-integrated!)
+ (integrate/expression operations environment new-expression))
+ (integration-failure))))
+
+ ((IGNORE)
+ (ignored-variable-warning (variable/name variable))
+ (integration-failure))
+
+ ((INTEGRATE INTEGRATE-OPERATOR)
+ (let ((new-expression (integrate/name expression
+ operator info environment)))
+ (if new-expression
+ (integration-success new-expression)
+ (integration-failure))))
+
+ (else
+ (error "Unknown operation" operation))))
+ (lambda ()
+ (integration-failure))))))
;;; sequence-operator
(define-method/integrate-combination 'SEQUENCE
(lambda (expression operations environment block operator operands)
(integrate-combination/default expression operations environment
- block operator operands)))
+ block operator operands)))
;;; the-environment-operator
(define-method/integrate-combination 'THE-ENVIRONMENT
(lambda (expression operations environment block operator operands)
(warn "(THE-ENVIRONMENT) used as an operator. Will cause a runtime error.")
(combination/make expression block
- (integrate/expression operations environment operator)
- operands)))
+ (integrate/expression operations environment operator)
+ operands)))
(define (integrate-combination/default expression operations environment
- block operator operands)
+ block operator operands)
(combination/make
expression
block
(let* ((integrate-procedure
- (lambda (operator)
- (integrate/procedure-operator operations environment
- block operator operands)))
- (operator
- (if (procedure? operator)
- (integrate-procedure operator)
- (let ((operator
- (integrate/expression operations
- environment
- operator)))
- (if (procedure? operator)
- (integrate-procedure operator)
- operator)))))
+ (lambda (operator)
+ (integrate/procedure-operator operations environment
+ block operator operands)))
+ (operator
+ (if (procedure? operator)
+ (integrate-procedure operator)
+ (let ((operator
+ (integrate/expression operations
+ environment
+ operator)))
+ (if (procedure? operator)
+ (integrate-procedure operator)
+ operator)))))
(cond ((integrate/compound-operator operator operands)
- => integrate-procedure)
- (else operator)))
+ => integrate-procedure)
+ (else operator)))
operands))
(define (integrate/hack-apply? operands)
(define (check operand)
(cond ((constant? operand)
- (if (null? (constant/value operand))
- '()
- 'FAIL))
- ((not (combination? operand))
- 'FAIL)
- (else
- (let ((rator (combination/operator operand)))
- (if (or (and (constant? rator)
- (eq? (ucode-primitive cons)
- (constant/value rator)))
- (eq? 'cons (global-ref? rator)))
- (let* ((rands (combination/operands operand))
- (next (check (cadr rands))))
- (if (eq? next 'FAIL)
- 'FAIL
- (cons (car rands) next)))
- 'FAIL)))))
+ (if (null? (constant/value operand))
+ '()
+ 'FAIL))
+ ((not (combination? operand))
+ 'FAIL)
+ (else
+ (let ((rator (combination/operator operand)))
+ (if (or (and (constant? rator)
+ (eq? (ucode-primitive cons)
+ (constant/value rator)))
+ (eq? 'cons (global-ref? rator)))
+ (let* ((rands (combination/operands operand))
+ (next (check (cadr rands))))
+ (if (eq? next 'FAIL)
+ 'FAIL
+ (cons (car rands) next)))
+ 'FAIL)))))
(and (not (null? operands))
(let ((tail (check (car (last-pair operands)))))
- (and (not (eq? tail 'FAIL))
- (append (except-last-pair operands)
- tail)))))
+ (and (not (eq? tail 'FAIL))
+ (append (except-last-pair operands)
+ tail)))))
\f
;;; ((let ((a (foo)) (b (bar)))
(define (integrate/compound-operator operator operands)
(define (scan-body body encloser)
(if (procedure? body)
- (and (not (open-block? (procedure/body body)))
- (procedure-with-body body (encloser (procedure/body body))))
- (scan-operator body encloser)))
+ (and (not (open-block? (procedure/body body)))
+ (procedure-with-body body (encloser (procedure/body body))))
+ (scan-operator body encloser)))
(define (scan-operator operator encloser)
(cond ((sequence? operator)
- (let ((reversed-actions (reverse (sequence/actions operator))))
- (scan-body (car reversed-actions)
- (let ((commands (cdr reversed-actions)))
- (lambda (expression)
- (encloser
- (sequence-with-actions
- operator
- (reverse (cons expression commands)))))))))
- ((combination? operator)
- (let ((descend
- (lambda (operator*)
- (and (not (open-block? (procedure/body operator*)))
- (scan-body
- (procedure/body operator*)
- (lambda (body*)
- (encloser
- (combination-with-operator
- operator
- (procedure-with-body operator* body*))))))))
- (operator* (combination/operator operator)))
- (cond ((procedure? operator*) (descend operator*))
- ((integrate/compound-operator
- operator*
- (combination/operands operator))
- => descend)
- (else #f))))
- ((declaration? operator)
- (scan-body (declaration/expression operator)
- (lambda (expression)
- (encloser
- (declaration-with-expression operator expression)))))
- (else #f)))
+ (let ((reversed-actions (reverse (sequence/actions operator))))
+ (scan-body (car reversed-actions)
+ (let ((commands (cdr reversed-actions)))
+ (lambda (expression)
+ (encloser
+ (sequence-with-actions
+ operator
+ (reverse (cons expression commands)))))))))
+ ((combination? operator)
+ (let ((descend
+ (lambda (operator*)
+ (and (not (open-block? (procedure/body operator*)))
+ (scan-body
+ (procedure/body operator*)
+ (lambda (body*)
+ (encloser
+ (combination-with-operator
+ operator
+ (procedure-with-body operator* body*))))))))
+ (operator* (combination/operator operator)))
+ (cond ((procedure? operator*) (descend operator*))
+ ((integrate/compound-operator
+ operator*
+ (combination/operands operator))
+ => descend)
+ (else #f))))
+ ((declaration? operator)
+ (scan-body (declaration/expression operator)
+ (lambda (expression)
+ (encloser
+ (declaration-with-expression operator expression)))))
+ (else #f)))
(and (for-all? operands expression/effect-free?)
(scan-operator operator (lambda (body) body))))
\f
(define (combination-with-operator combination operator)
(combination/make combination
- (combination/block combination)
- operator
- (combination/operands combination)))
+ (combination/block combination)
+ operator
+ (combination/operands combination)))
(define (declaration-with-expression declaration expression)
(declaration/make (declaration/scode declaration)
- (declaration/declarations declaration)
- expression))
+ (declaration/declarations declaration)
+ expression))
;;; Replacing the body may cause variables from outside the original
;;; body to be shadowed, so we use a sleazy stupid hack to work around
(for-each hackify-variable (procedure/optional procedure))
(cond ((procedure/rest procedure) => hackify-variable))
(procedure/make (procedure/scode procedure)
- (procedure/block procedure)
- (procedure/name procedure)
- (procedure/required procedure)
- (procedure/optional procedure)
- (procedure/rest procedure)
- body))
+ (procedure/block procedure)
+ (procedure/name procedure)
+ (procedure/required procedure)
+ (procedure/optional procedure)
+ (procedure/rest procedure)
+ body))
(define (hackify-variable variable)
(set-variable/name!
;; integrate one another. When circularities are detected within
;; the definition-reference graph, integration is disabled.
(let ((vals
- (map (lambda (value)
- (delayed-integration/make operations value))
- vals)))
+ (map (lambda (value)
+ (delayed-integration/make operations value))
+ vals)))
(let ((environment
- (environment/bind-multiple environment variables vals)))
+ (environment/bind-multiple environment variables vals)))
(for-each (lambda (value)
- (set-delayed-integration/environment! value environment))
- vals)
+ (set-delayed-integration/environment! value environment))
+ vals)
(values environment (map delayed-integration/force vals)))))
(define (integrate/name expr reference info environment)
(let ((variable (reference/variable reference)))
(let ((finish
- (lambda (value)
- (reassign
- expr
- (copy/expression/intern (reference/block reference) value)))))
+ (lambda (value)
+ (reassign
+ expr
+ (copy/expression/intern (reference/block reference) value)))))
(if info
- (finish (integration-info/expression info))
- (environment/lookup environment variable
- (lambda (value)
- (if (delayed-integration? value)
- (if (delayed-integration/in-progress? value)
- #f
- (finish (delayed-integration/force value)))
- (finish value)))
- false-procedure
- false-procedure)))))
+ (finish (integration-info/expression info))
+ (environment/lookup environment variable
+ (lambda (value)
+ (if (delayed-integration? value)
+ (if (delayed-integration/in-progress? value)
+ #f
+ (finish (delayed-integration/force value)))
+ (finish value)))
+ false-procedure
+ false-procedure)))))
(define (variable/final-value variable environment if-value if-not)
(environment/lookup environment variable
(lambda (value)
(if (delayed-integration? value)
- (if (delayed-integration/in-progress? value)
- (error "Unfinished integration" value)
- (if-value (delayed-integration/force value)))
- (if-value value)))
+ (if (delayed-integration/in-progress? value)
+ (error "Unfinished integration" value)
+ (if-value (delayed-integration/force value)))
+ (if-value value)))
(lambda ()
(if-not))
(lambda ()
(case (delayed-integration/state delayed-integration)
((NOT-INTEGRATED)
(let ((value
- (let ((environment
- (delayed-integration/environment delayed-integration))
- (operations
- (delayed-integration/operations delayed-integration))
- (expression (delayed-integration/value delayed-integration)))
- (set-delayed-integration/state! delayed-integration
- 'BEING-INTEGRATED)
- (set-delayed-integration/environment! delayed-integration #f)
- (set-delayed-integration/operations! delayed-integration #f)
- (set-delayed-integration/value! delayed-integration #f)
- (integrate/expression operations environment expression))))
+ (let ((environment
+ (delayed-integration/environment delayed-integration))
+ (operations
+ (delayed-integration/operations delayed-integration))
+ (expression (delayed-integration/value delayed-integration)))
+ (set-delayed-integration/state! delayed-integration
+ 'BEING-INTEGRATED)
+ (set-delayed-integration/environment! delayed-integration #f)
+ (set-delayed-integration/operations! delayed-integration #f)
+ (set-delayed-integration/value! delayed-integration #f)
+ (integrate/expression operations environment expression))))
(set-delayed-integration/state! delayed-integration 'INTEGRATED)
(set-delayed-integration/value! delayed-integration value)))
((INTEGRATED) 'DONE)
((BEING-INTEGRATED)
(error "Attempt to re-force delayed integration"
- delayed-integration))
+ delayed-integration))
(else
(error "Delayed integration has unknown state"
- delayed-integration)))
+ delayed-integration)))
(delayed-integration/value delayed-integration))
\ No newline at end of file
projects / mit-scheme.git / commitdiff