--- /dev/null
+;; DO NOT: (declare (usual-integrations))
+
+;;;; (scode-optimizer cross)
+\f
+(define cross-sf/false-value #F)
+(define cross-sf/true-value #T)
+(define cross-sf/null-value '())
+(define cross-sf/unspecific-value unspecific)
+
+(define cross-sf/constants/false #F) ; the value of #F when reading a file
+(define cross-sf/constants/true #T) ; not used
+(define cross-sf/constants/null '()) ; not used
+(define cross-sf/constants/unspecific '()) ; not used
+
+(define cross-sf/bin-pathname-type #f) ; if not #F, replacement type
+
+;; if #F, typecodes are the same on target system
+;; if not #F, a utabmd.scm file decribing new typecodes
+(define cross-sf/utab-file #f)
+;; Cached fixed-objects-vector as specified by cross-sf/utab-file
+(define cross-sf/fov #f)
+
+
+(define (cross-sf/get-fixed-objects-vector)
+
+ (define (read-utabmd filename)
+ ;; `interpret' the utabmd file. Relies on the very simple format of the
+ ;; source.
+ (display "\n;; Cross-SF: Typecodes specified by ")
+ (display filename)
+ (let* ((fov (make-vector (vector-length (get-fixed-objects-vector)))))
+ (with-input-from-file filename
+ (lambda ()
+ (let loop ()
+ (let ((expr (read)))
+ (cond ((eof-object? expr) fov)
+ ((and (pair? expr)
+ (equal? (car expr) 'vector-set!))
+ (vector-set! fov (third expr) (fourth expr))
+ (loop))
+ (else (loop)))))))))
+
+ (if cross-sf/utab-file
+ (or cross-sf/fov
+ (begin (set! cross-sf/fov (read-utabmd cross-sf/utab-file))
+ cross-sf/fov))
+ (get-fixed-objects-vector)))
+
+
+;;; The following 3 procedures are trivially renamed from
+;;; runtime/utabs.scm because GET-FIXED-OBJECTS-VECTOR is an
+;;; integrated primitive an thus we cant just fluid-let it.
+
+(define (cross-sf/ucode-type type-name)
+ (or (cross-sf/microcode-type/name->code type-name)
+ (error "CROSS-SF/MICROCODE-TYPE: Unknown name" type-name)))
+
+(define (cross-sf/microcode-type/name->code name)
+ (let ((types-slot (fixed-object/name->code 'MICROCODE-TYPES-VECTOR)))
+ (cross-sf/microcode-table-search types-slot name)))
+
+(define (cross-sf/microcode-table-search slot name)
+ (let ((vector (vector-ref (cross-sf/get-fixed-objects-vector) slot)))
+ (let ((end (vector-length vector)))
+ (define (loop i)
+ (and (not (= i end))
+ (let ((entry (vector-ref vector i)))
+ (if (if (pair? entry)
+ (memq name entry)
+ (eq? name entry))
+ i
+ (loop (1+ i))))))
+ (loop 0))))
+
+
+(define (cross-sf/hack-sharp-f-reader!)
+ (define (cross-sf/parse-object/false)
+ (parse-object/false)
+ cross-sf/false-value)
+ (parser-table/set-entry! system-global-parser-table
+ '("#f" "#F")
+ cross-sf/parse-object/false)
+ 'DONE)
+
+
+(define (with-cross-sf thunk)
+ (cross-sf/hack-sharp-f-reader!)
+
+ ;; Cross-sf parameters:
+ (fluid-let ((bin-pathname-type (or cross-sf/bin-pathname-type
+ bin-pathname-type))
+ (cross-sf/false-value cross-sf/constants/false)
+ (cross-sf/true-value cross-sf/constants/true)
+ (cross-sf/null-value cross-sf/constants/null)
+ (cross-sf/unspecific-value cross-sf/constants/unspecific)
+ (cross-sf/fov #f) ; clear cache
+ (microcode-type cross-sf/ucode-type)
+ )
+
+ ;; Effecting parameters on the system:
+ (fluid-let ((usual-integrations/expansion-alist
+ (usual-integrations/make-expansion-alist)))
+
+ (dynamic-wind
+ (lambda ()
+ ;;; Global integrable bindings dependent upon parameters:
+ ;; It is assumed that these names have all been integrated in any code
+ ;; reachable from USUAL-INTEGRATIONS/CACHE!, so that these
+ ;; redefinitions will not change it's behaviour.
+
+ (fluid-let ((false cross-sf/false-value)
+ (true cross-sf/true-value)
+ (unspecific cross-sf/unspecific-value)
+ ;; There are assumptions! They should be checked against
+ ;; their definitions in the microcode/runtime.
+ (*the-non-printing-object* cross-sf/unspecific-value)
+ (the-empty-stream cross-sf/null-value)
+ (system-global-environment cross-sf/false-value)
+ )
+
+ (usual-integrations/cache!)))
+
+ thunk
+
+ (lambda ()
+ ;; undo bindings to global integrable constants
+ (usual-integrations/cache!))))))
+
+
+
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: gconst.scm,v 1.1 1995/03/07 22:13:52 adams Exp $
+
+Copyright (c) 1987-93 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Optimizer: Global Constants List
+;;; package: (scode-optimizer)
+
+(declare (usual-integrations))
+\f
+;;; This is a list of names that are bound in the global environment.
+;;; Normally the compiler will replace references to one of these
+;;; names with the value of that name, which is a constant.
+
+(define global-constant-objects
+ '(
+ %RECORD
+ %RECORD-LENGTH
+ %RECORD-REF
+ %RECORD-SET!
+ *THE-NON-PRINTING-OBJECT*
+ ASCII->CHAR
+ BIT-STRING->UNSIGNED-INTEGER
+ BIT-STRING-ALLOCATE
+ BIT-STRING-AND!
+ BIT-STRING-ANDC!
+ BIT-STRING-CLEAR!
+ BIT-STRING-FILL!
+ BIT-STRING-LENGTH
+ BIT-STRING-MOVE!
+ BIT-STRING-MOVEC!
+ BIT-STRING-OR!
+ BIT-STRING-REF
+ BIT-STRING-SET!
+ BIT-STRING-XOR!
+ BIT-STRING-ZERO?
+ BIT-STRING=?
+ BIT-STRING?
+ BIT-SUBSTRING-FIND-NEXT-SET-BIT
+ BIT-SUBSTRING-MOVE-RIGHT!
+ CAR
+ CDR
+ CELL-CONTENTS
+ CHAR->ASCII
+ CHAR->INTEGER
+ CHAR-ASCII?
+ CHAR-BITS
+ CHAR-BITS-LIMIT
+ CHAR-CODE
+ CHAR-CODE-LIMIT
+ CHAR-DOWNCASE
+ CHAR-INTEGER-LIMIT
+ CHAR-UPCASE
+ CHAR:NEWLINE
+ COMPILED-CODE-ADDRESS->BLOCK
+ COMPILED-CODE-ADDRESS->OFFSET
+ CONS
+ ENABLE-INTERRUPTS!
+ EQ?
+ ERROR-PROCEDURE
+ FALSE
+ FALSE?
+ FIX:*
+ FIX:+
+ FIX:-
+ FIX:-1+
+ FIX:1+
+ FIX:<
+ ;; FIX:= handled by expanding it to EQ?
+ FIX:>
+ FIX:AND
+ FIX:ANDC
+ FIX:DIVIDE
+ FIX:FIXNUM?
+ FIX:GCD
+ FIX:LSH
+ FIX:NEGATIVE?
+ FIX:NOT
+ FIX:OR
+ FIX:POSITIVE?
+ FIX:QUOTIENT
+ FIX:REMAINDER
+ FIX:XOR
+ FIXNUM?
+ ;; FIX:ZERO? handled by expanding it to (EQ? x 0)
+ FLO:*
+ FLO:+
+ FLO:-
+ FLO:/
+ FLO:<
+ FLO:=
+ FLO:>
+ FLO:ABS
+ FLO:ACOS
+ FLO:ASIN
+ FLO:ATAN
+ FLO:ATAN2
+ FLO:CEILING
+ FLO:CEILING->EXACT
+ FLO:COS
+ FLO:EXP
+ FLO:EXPT
+ FLO:FLOOR
+ FLO:FLOOR->EXACT
+ FLO:LOG
+ FLO:NEGATE
+ FLO:NEGATIVE?
+ FLO:POSITIVE?
+ FLO:ROUND
+ FLO:ROUND->EXACT
+ FLO:SIN
+ FLO:SQRT
+ FLO:TAN
+ FLO:TRUNCATE
+ FLO:TRUNCATE->EXACT
+ FLO:VECTOR-CONS
+ FLO:VECTOR-LENGTH
+ FLO:VECTOR-REF
+ FLO:VECTOR-SET!
+ FLO:ZERO?
+ FORCE
+ GENERAL-CAR-CDR
+ GET-FIXED-OBJECTS-VECTOR
+ GET-NEXT-CONSTANT
+ HUNK3-CONS
+ INDEX-FIXNUM?
+ INT:*
+ INT:+
+ INT:-
+ INT:-1+
+ INT:1+
+ INT:<
+ INT:=
+ INT:>
+ INT:DIVIDE
+ INT:NEGATE
+ INT:NEGATIVE?
+ INT:POSITIVE?
+ INT:QUOTIENT
+ INT:REMAINDER
+ INT:ZERO?
+ INTEGER->CHAR
+ INTEGER-DIVIDE-QUOTIENT
+ INTEGER-DIVIDE-REMAINDER
+ ;; What the hell are these doing here?
+ INTERRUPT-BIT/AFTER-GC
+ INTERRUPT-BIT/GC
+ INTERRUPT-BIT/GLOBAL-1
+ INTERRUPT-BIT/GLOBAL-3
+ INTERRUPT-BIT/GLOBAL-GC
+ INTERRUPT-BIT/KBD
+ INTERRUPT-BIT/STACK
+ INTERRUPT-BIT/SUSPEND
+ INTERRUPT-BIT/TIMER
+ INTERRUPT-MASK/ALL
+ INTERRUPT-MASK/GC-OK
+ INTERRUPT-MASK/NONE
+ INTERRUPT-MASK/TIMER-OK
+ LAMBDA-TAG:FLUID-LET
+ LAMBDA-TAG:LET
+ LAMBDA-TAG:MAKE-ENVIRONMENT
+ LAMBDA-TAG:UNNAMED
+ LENGTH
+ LEXICAL-ASSIGNMENT
+ LEXICAL-REFERENCE
+ LEXICAL-UNASSIGNED?
+ LEXICAL-UNBOUND?
+ LEXICAL-UNREFERENCEABLE?
+ LIST->VECTOR
+ LOCAL-ASSIGNMENT
+ MAKE-BIT-STRING
+ MAKE-CELL
+ MAKE-CHAR
+ MAKE-NON-POINTER-OBJECT
+ ;; MODULO ; expanded to primitive. Global defn. is not.
+ NOT
+ NULL?
+ OBJECT-CONSTANT?
+ OBJECT-DATUM
+ OBJECT-GC-TYPE
+ OBJECT-NEW-TYPE
+ OBJECT-PURE?
+ OBJECT-TYPE
+ OBJECT-TYPE?
+ PAIR?
+ PRIMITIVE-PROCEDURE-ARITY
+ PROCESS-TIME-CLOCK
+ ;; QUOTIENT ; expanded to primitive. Global defn. is not.
+ READ-BITS!
+ REAL-TIME-CLOCK
+ ;; REMAINDER ; expanded to primitive. Global defn. is not.
+ SET-CAR!
+ SET-CDR!
+ SET-CELL-CONTENTS!
+ SET-INTERRUPT-ENABLES!
+ SET-STRING-LENGTH!
+ ;; STRING->SYMBOL ; Runtime version copies the string
+ STRING-ALLOCATE
+ STRING-HASH
+ STRING-HASH-MOD
+ STRING-LENGTH
+ STRING-MAXIMUM-LENGTH
+ STRING-REF
+ STRING-SET!
+ STRING?
+ SUBSTRING-CI=?
+ SUBSTRING-DOWNCASE!
+ SUBSTRING-FIND-NEXT-CHAR-IN-SET
+ SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET
+ SUBSTRING-MATCH-BACKWARD
+ SUBSTRING-MATCH-BACKWARD-CI
+ SUBSTRING-MATCH-FORWARD
+ SUBSTRING-MATCH-FORWARD-CI
+ SUBSTRING-MOVE-LEFT!
+ SUBSTRING-MOVE-RIGHT!
+ SUBSTRING-UPCASE!
+ SUBSTRING<?
+ SUBSTRING=?
+ SUBVECTOR->LIST
+ SUBVECTOR-FILL!
+ SUBVECTOR-MOVE-LEFT!
+ SUBVECTOR-MOVE-RIGHT!
+ SYSTEM-GLOBAL-ENVIRONMENT
+ SYSTEM-HUNK3-CXR0
+ SYSTEM-HUNK3-CXR1
+ SYSTEM-HUNK3-CXR2
+ SYSTEM-HUNK3-SET-CXR0!
+ SYSTEM-HUNK3-SET-CXR1!
+ SYSTEM-HUNK3-SET-CXR2!
+ SYSTEM-LIST->VECTOR
+ SYSTEM-PAIR-CAR
+ SYSTEM-PAIR-CDR
+ SYSTEM-PAIR-CONS
+ SYSTEM-PAIR-SET-CAR!
+ SYSTEM-PAIR-SET-CDR!
+ SYSTEM-PAIR?
+ SYSTEM-SUBVECTOR->LIST
+ SYSTEM-VECTOR-LENGTH
+ SYSTEM-VECTOR-REF
+ SYSTEM-VECTOR-SET!
+ SYSTEM-VECTOR?
+ THE-EMPTY-STREAM
+ TRUE
+ UNDEFINED-CONDITIONAL-BRANCH
+ UNSIGNED-INTEGER->BIT-STRING
+ UNSPECIFIC
+ VECTOR
+ VECTOR-8B-FILL!
+ VECTOR-8B-FIND-NEXT-CHAR
+ VECTOR-8B-FIND-NEXT-CHAR-CI
+ VECTOR-8B-FIND-PREVIOUS-CHAR
+ VECTOR-8B-FIND-PREVIOUS-CHAR-CI
+ VECTOR-8B-REF
+ VECTOR-8B-SET!
+ VECTOR-LENGTH
+ VECTOR-REF
+ VECTOR-SET!
+ WITH-HISTORY-DISABLED
+ WITH-INTERRUPT-MASK
+ WRITE-BITS!
+ ))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: pardec.scm,v 1.1 1995/03/07 22:20:43 adams Exp $
+
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Optimizer: Parse Declarations
+;;; package: (scode-optimizer declarations)
+
+(declare (usual-integrations)
+ (integrate-external "object"))
+\f
+;;;; Main Entry Points
+
+(define (declarations/parse block declarations)
+ (make-declaration-set declarations
+ (append-map (lambda (declaration)
+ (parse-declaration block declaration))
+ declarations)))
+
+(define (declarations/make-null)
+ (make-declaration-set '() '()))
+
+(define (declarations/original declaration-set)
+ (declaration-set/original declaration-set))
+
+(define (declarations/bind operations declaration-set)
+ (let loop
+ ((operations operations)
+ (declarations (declaration-set/declarations declaration-set)))
+ (if (null? declarations)
+ operations
+ (loop (let ((declaration (car declarations)))
+ ((if (declaration/overridable? declaration)
+ operations/bind-global
+ operations/bind)
+ operations
+ (declaration/operation declaration)
+ (declaration/variable declaration)
+ (declaration/value declaration)))
+ (cdr declarations)))))
+
+(define (declarations/map declaration-set per-variable per-value)
+ (make-declaration-set
+ (declaration-set/original declaration-set)
+ (map (lambda (declaration)
+ (make-declaration (declaration/operation declaration)
+ (per-variable (declaration/variable declaration))
+ (let ((value (declaration/value declaration)))
+ (and value
+ (per-value value)))
+ (declaration/overridable? declaration)))
+ (declaration-set/declarations declaration-set))))
+
+(define (declarations/known? declaration)
+ (assq (car declaration) known-declarations))
+\f
+;;;; Data Structures
+
+(define-structure (declaration-set
+ (type vector)
+ (named
+ (string->symbol
+ "#[(scode-optimizer declarations)declaration-set]"))
+ (constructor make-declaration-set)
+ (conc-name declaration-set/))
+ (original false read-only true)
+ (declarations false read-only true))
+
+(define-structure (declaration
+ (type vector)
+ (named
+ (string->symbol
+ "#[(scode-optimizer declarations)declaration]"))
+ (constructor make-declaration)
+ (conc-name declaration/))
+ ;; OPERATION is the name of the operation that is to be performed by
+ ;; this declaration.
+ (operation false read-only true)
+
+ ;; The variable that this declaration affects.
+ (variable false read-only true)
+
+ ;; The value associated with this declaration. The meaning of this
+ ;; field depends on OPERATION.
+ (value false read-only true)
+
+ ;; OVERRIDABLE? means that a user-defined variable of the same name
+ ;; will override this declaration. It also means that this
+ ;; declaration should not be written out to the ".ext" file.
+ (overridable? false read-only true))
+
+(define (make-declarations operation variables values overridable?)
+ (if (eq? values 'NO-VALUES)
+ (map (lambda (variable)
+ (make-declaration operation variable false overridable?))
+ variables)
+ (map (lambda (variable value)
+ (make-declaration operation variable value overridable?))
+ variables
+ values)))
+
+(define (parse-declaration block declaration)
+ (let ((association (assq (car declaration) known-declarations)))
+ (if (not association)
+ '()
+ ((cdr association) block (cdr declaration)))))
+
+(define (define-declaration operation parser)
+ (let ((entry (assq operation known-declarations)))
+ (if entry
+ (set-cdr! entry parser)
+ (set! known-declarations
+ (cons (cons operation parser)
+ known-declarations))))
+ operation)
+
+(define known-declarations
+ '())
+\f
+;;;; Integration Declarations
+
+(define-declaration 'USUAL-INTEGRATIONS
+ ;; This is written in a strange way because the obvious way to write
+ ;; it is quadratic in the number of names being declared. Since
+ ;; there are typically over 300 names, this matters some. I believe
+ ;; this algorithm is linear in the number of names.
+ (lambda (block deletions)
+ (let ((deletions
+ (append sf/usual-integrations-default-deletions deletions))
+ (declarations '())
+ (remaining '()))
+ (let ((do-deletions
+ (lambda (name.val-alist)
+ (if (null? deletions)
+ name.val-alist
+ (let deletion-loop
+ ((name.val-alist name.val-alist)
+ (survivors '()))
+ (cond ((null? name.val-alist)
+ survivors)
+ ((memq (caar name.val-alist) deletions)
+ (deletion-loop (cdr name.val-alist) survivors))
+ (else
+ (deletion-loop (cdr name.val-alist)
+ (cons (car name.val-alist)
+ survivors))))))))
+ (constructor
+ (lambda (operation)
+ (lambda (name.value)
+ (let ((name (car name.value))
+ (value (cdr name.value)))
+ (let ((variable (block/lookup-name block name false)))
+ (if variable
+ (set! declarations
+ (cons (make-declaration operation
+ variable
+ value
+ true)
+ declarations))
+ (set! remaining
+ (cons (vector operation name value)
+ remaining))))
+ unspecific)))))
+ (let ((expansion-alist
+ (do-deletions usual-integrations/expansion-alist)))
+ (for-each (constructor 'EXPAND) expansion-alist))
+ (let ((constant-alist
+ (do-deletions usual-integrations/constant-alist-names*values)))
+ (for-each (constructor 'INTEGRATE) constant-alist)))
+ (map* declarations
+ (let ((top-level-block
+ (let loop ((block block))
+ (if (block/parent block)
+ (loop (block/parent block))
+ block))))
+ (lambda (remaining)
+ (make-declaration
+ (vector-ref remaining 0)
+ (variable/make&bind! top-level-block (vector-ref remaining 1))
+ (vector-ref remaining 2)
+ true)))
+ remaining))))
+\f
+;;(define-declaration 'USUAL-INTEGRATIONS
+;; ;; This is written in a strange way because the obvious way to write
+;; ;; it is quadratic in the number of names being declared. Since
+;; ;; there are typically over 300 names, this matters some. I believe
+;; ;; this algorithm is linear in the number of names.
+;; (lambda (block deletions)
+;; (let ((deletions
+;; (append sf/usual-integrations-default-deletions deletions))
+;; (declarations '())
+;; (remaining '()))
+;; (let ((do-deletions
+;; (lambda (names vals)
+;; (if (null? deletions)
+;; (values names vals)
+;; (let deletion-loop
+;; ((names names)
+;; (vals vals)
+;; (names* '())
+;; (vals* '()))
+;; (cond ((null? names)
+;; (values names* vals*))
+;; ((memq (car names) deletions)
+;; (deletion-loop (cdr names)
+;; (cdr vals)
+;; names*
+;; vals*))
+;; (else
+;; (deletion-loop (cdr names)
+;; (cdr vals)
+;; (cons (car names) names*)
+;; (cons (car vals) vals*))))))))
+;; (constructor
+;; (lambda (operation)
+;; (lambda (name value)
+;; (let ((variable (block/lookup-name block name false)))
+;; (if variable
+;; (set! declarations
+;; (cons (make-declaration operation
+;; variable
+;; value
+;; true)
+;; declarations))
+;; (set! remaining
+;; (cons (vector operation name value)
+;; remaining))))
+;; unspecific))))
+;; (call-with-values
+;; (lambda ()
+;; (do-deletions usual-integrations/expansion-names
+;; usual-integrations/expansion-values))
+;; (lambda (expansion-names expansion-values)
+;; (for-each (constructor 'EXPAND)
+;; expansion-names
+;; expansion-values)))
+;; (call-with-values
+;; (lambda ()
+;; (do-deletions usual-integrations/constant-names
+;; usual-integrations/constant-values))
+;; (lambda (constant-names constant-values)
+;; (for-each (constructor 'INTEGRATE)
+;; constant-names
+;; constant-values))))
+;; (map* declarations
+;; (let ((top-level-block
+;; (let loop ((block block))
+;; (if (block/parent block)
+;; (loop (block/parent block))
+;; block))))
+;; (lambda (remaining)
+;; (make-declaration
+;; (vector-ref remaining 0)
+;; (variable/make&bind! top-level-block (vector-ref remaining 1))
+;; (vector-ref remaining 2)
+;; true)))
+;; remaining))))
+\f
+(define (define-integration-declaration operation)
+ (define-declaration operation
+ (lambda (block names)
+ (make-declarations operation
+ (block/lookup-names block names true)
+ 'NO-VALUES
+ false))))
+
+(define-integration-declaration 'INTEGRATE)
+(define-integration-declaration 'INTEGRATE-OPERATOR)
+(define-integration-declaration 'INTEGRATE-SAFELY)
+
+(define-declaration 'INTEGRATE-EXTERNAL
+ (lambda (block specifications)
+ (append-map
+ (lambda (pathname)
+ (call-with-values (lambda () (read-externs-file pathname))
+ (lambda (externs-block externs)
+ (if externs-block
+ (change-type/block externs-block))
+ (append-map
+ (lambda (extern)
+ (let ((operation (vector-ref extern 0))
+ (name (vector-ref extern 1))
+ (value (vector-ref extern 2)))
+ (if (and (eq? 'EXPAND operation)
+ (dumped-expander? value))
+ (parse-declaration block
+ (dumped-expander/declaration value))
+ (begin
+ (change-type/expression value)
+ (list
+ (make-declaration operation
+ (if (symbol? name)
+ (block/lookup-name block name true)
+ name)
+ (make-integration-info
+ (copy/expression/extern block value))
+ true))))))
+ externs))))
+ (append-map (lambda (specification)
+ (let ((value
+ (scode-eval
+ (syntax specification
+ system-global-syntax-table)
+ syntaxer/default-environment)))
+ (if (pair? value)
+ (map ->pathname value)
+ (list (->pathname value)))))
+ specifications))))
+
+(define (operations->external operations environment)
+ (let ((block (block/make false false '())))
+ (values
+ block
+ (delq! false
+ (operations/map-external operations
+ (lambda (operation variable value)
+ (let ((finish
+ (lambda (value)
+ (vector operation
+ (variable/name variable)
+ (copy/expression/extern block value)))))
+ (cond ((not value)
+ (variable/final-value variable
+ environment
+ finish
+ (lambda () false)))
+ ((integration-info? value)
+ (finish (integration-info/expression value)))
+ ((dumpable-expander? value)
+ (vector operation
+ (if (variable? variable)
+ (variable/name variable)
+ variable)
+ (dumpable-expander->dumped-expander value)))
+ (else
+ (error "Unrecognized extern value:" value))))))))))
+\f
+;;;; Flag Declarations
+
+(for-each (lambda (flag)
+ (define-declaration flag
+ (lambda (block tail)
+ (if (not (null? tail))
+ (error "This declaration does not take arguments:"
+ (cons flag tail)))
+ (if (not (memq flag (block/flags block)))
+ (set-block/flags! block (cons flag (block/flags block))))
+ '())))
+ '(AUTOMAGIC-INTEGRATIONS
+ ETA-SUBSTITUTION
+ OPEN-BLOCK-OPTIMIZATIONS
+ NO-AUTOMAGIC-INTEGRATIONS
+ NO-ETA-SUBSTITUTION
+ NO-OPEN-BLOCK-OPTIMIZATIONS))
+
+(define-declaration 'IGNORE
+ (lambda (block names)
+ (for-each (lambda (variable)
+ (if variable
+ (variable/can-ignore! variable)))
+ (block/lookup-names block names false))
+ '()))
+\f
+;;;; Reductions and Expansions
+;;; See "reduct.scm" for description of REDUCE-OPERATOR and REPLACE-OPERATOR.
+
+(define-declaration 'REDUCE-OPERATOR
+ (lambda (block reduction-rules)
+ (check-declaration-syntax 'REDUCE-OPERATOR reduction-rules)
+ (map (lambda (rule)
+ (make-declaration 'EXPAND
+ (block/lookup-name block (car rule) true)
+ (make-dumpable-expander (reducer/make rule block)
+ `(REDUCE-OPERATOR ,rule))
+ false))
+ reduction-rules)))
+
+(define (check-declaration-syntax kind declarations)
+ (if (not (and (list? declarations)
+ (for-all? declarations
+ (lambda (declaration)
+ (and (pair? declaration)
+ (symbol? (car declaration))
+ (list? (cdr declaration)))))))
+ (error "Bad declaration:" kind declarations)))
+
+(define-declaration 'REPLACE-OPERATOR
+ (lambda (block replacements)
+ (if (not (and (list? replacements)
+ (for-all? replacements
+ (lambda (replacement)
+ (and (pair? replacement)
+ (or (symbol? (car replacement))
+ (and (pair? (car replacement))
+ (eq? 'PRIMITIVE (caar replacement))
+ (pair? (cdar replacement))
+ (symbol? (cadar replacement))
+ (or (null? (cddar replacement))
+ (and (pair? (cddar replacement))
+ (null? (cdddar replacement))))))
+ (list? (cdr replacement)))))))
+ (error "Bad declaration:" 'REPLACE-OPERATOR replacements))
+ (map (lambda (replacement)
+ (make-declaration
+ 'EXPAND
+ (let ((name (car replacement)))
+ (cond ((symbol? name)
+ (block/lookup-name block name true))
+ ((and (pair? name)
+ (eq? (car name) 'PRIMITIVE))
+ (make-primitive-procedure (cadr name)
+ (and (not (null? (cddr name)))
+ (caddr name))))
+ (else
+ (error "Illegal name in replacement:" name))))
+ (make-dumpable-expander
+ (replacement/make replacement block)
+ `(REPLACE-OPERATOR ,replacement))
+ false))
+ replacements)))
+\f
+(define (make-dumpable-expander expander declaration)
+ (make-entity (lambda (self expr operands if-expanded if-not-expanded block)
+ self ; ignored
+ (expander expr operands if-expanded if-not-expanded block))
+ (cons '*DUMPABLE-EXPANDER* declaration)))
+
+(define (dumpable-expander? object)
+ (and (entity? object)
+ (let ((extra (entity-extra object)))
+ (and (pair? extra)
+ (eq? '*DUMPABLE-EXPANDER* (car extra))))))
+
+(define (dumpable-expander->dumped-expander expander)
+ (cons dumped-expander-tag (cdr (entity-extra expander))))
+
+(define (dumped-expander? object)
+ (and (pair? object)
+ (eq? dumped-expander-tag (car object))))
+
+(define (dumped-expander/declaration expander)
+ (cdr expander))
+
+(define dumped-expander-tag
+ (string->symbol "#[(scode-optimizer declarations)dumped-expander]"))
+
+;;; Expansions. These should be used with great care, and require
+;;; knowing a fair amount about the internals of sf. This declaration
+;;; is purely a hook, with no convenience.
+
+(define-declaration 'EXPAND-OPERATOR
+ (lambda (block expanders)
+ block ;ignored
+ (map (lambda (expander)
+ (make-declaration 'EXPAND
+ (block/lookup-name block (car expander) true)
+ (eval (cadr expander)
+ expander-evaluation-environment)
+ false))
+ expanders)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: sf.pkg,v 1.1 1995/03/07 22:21:02 adams Exp $
+
+Copyright (c) 1987-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SF Packaging
+\f
+(global-definitions "../runtime/runtime")
+
+(define-package (scode-optimizer)
+ (files "lsets"
+ "table"
+ "pthmap"
+ "object"
+ "emodel"
+ "gconst"
+ "usicon"
+ "tables")
+ (parent ()))
+
+(define-package (scode-optimizer global-imports)
+ (files "gimprt")
+ (parent ())
+ (export (scode-optimizer)
+ scode-assignment?
+ scode-open-block?
+ scode-sequence?))
+
+(define-package (scode-optimizer top-level)
+ (files "toplev")
+ (parent (scode-optimizer))
+ (export ()
+ bin-pathname-type
+ sf
+ sf/add-file-declarations!
+ sf/default-declarations
+ sf/default-syntax-table
+ sf/pathname-defaulting
+ sf/set-default-syntax-table!
+ sf/set-file-syntax-table!
+ 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)
+ (import (runtime syntaxer)
+ process-declarations))
+
+(define-package (scode-optimizer transform)
+ (files "xform")
+ (parent (scode-optimizer))
+ (export (scode-optimizer)
+ transform/top-level
+ transform/recursive))
+
+(define-package (scode-optimizer integrate)
+ (files "subst")
+ (parent (scode-optimizer))
+ (export (scode-optimizer)
+ integrate/top-level
+ integrate/get-top-level-block
+ reassign
+ variable/final-value)
+ (import (runtime parser)
+ lambda-optional-tag))
+
+(define-package (scode-optimizer cgen)
+ (files "cgen")
+ (parent (scode-optimizer))
+ (export (scode-optimizer)
+ *sf-associate*
+ cgen/external)
+ (export (scode-optimizer expansion)
+ 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-alist)
+ (export (scode-optimizer declarations)
+ 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
+ operations->external))
+
+(define-package (scode-optimizer copy)
+ (files "copy")
+ (parent (scode-optimizer))
+ (export (scode-optimizer)
+ copy/expression/intern
+ copy/expression/extern))
+
+(define-package (scode-optimizer free)
+ (files "free")
+ (parent (scode-optimizer))
+ (export (scode-optimizer)
+ free/expression))
+
+(define-package (scode-optimizer change-type)
+ (files "chtype")
+ (parent (scode-optimizer))
+ (export (scode-optimizer)
+ change-type/block
+ change-type/expression))
+
+(define-package (scode-optimizer build-utilities)
+ (files "butils")
+ (parent ())
+ (export ()
+ compile-directory
+ compile-directory?
+ file-processed?
+ sf-conditionally
+ sf-directory
+ sf-directory?))
+
+(define-package (scode-optimizer cross-sf)
+ (files "cross")
+ (parent ())
+ (import (runtime parser)
+ parse-object/false)
+ (import (scode-optimizer expansion)
+ usual-integrations/expansion-alist
+ usual-integrations/make-expansion-alist)
+ (import (scode-optimizer)
+ usual-integrations/cache!)
+ (export ()
+ cross-sf/false-value
+ cross-sf/utab-file
+ cross-sf/bin-pathname-type
+ cross-sf/constants/false
+ cross-sf/constants/true
+ cross-sf/constants/null
+ cross-sf/constants/unspecific
+ cross-sf/ucode-type
+ with-cross-sf))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: subst.scm,v 1.1 1995/03/07 22:13:23 adams Exp $
+
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Optimizer: Beta Substitution
+;;; package: (scode-optimizer integrate)
+
+(declare (usual-integrations)
+ (integrate-external "object" "lsets"))
+\f
+(define *top-level-block*)
+
+(define (integrate/get-top-level-block)
+ *top-level-block*)
+
+;;; Block names are added to this list so warnings can be more
+;;; descriptive.
+(define *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* '()))
+ (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))))
+ (process-block-flags (block/flags block)
+ (lambda ()
+ (values operations
+ environment
+ (integrate/expression operations
+ environment
+ expression))))))))
+ (lambda (operations environment expression)
+ (values operations environment
+ (quotation/make scode
+ block
+ expression))))))
+
+(define (integrate/expressions operations environment expressions)
+ (map (lambda (expression)
+ (integrate/expression operations environment expression))
+ expressions))
+
+(define (integrate/expression operations environment expression)
+ ((expression/method dispatch-vector expression)
+ operations environment expression))
+
+(define dispatch-vector
+ (expression/make-dispatch-vector))
+
+(define define-method/integrate
+ (expression/make-method-definer dispatch-vector))
+\f
+;;;; Variables
+
+(define-method/integrate 'ASSIGNMENT
+ (lambda (operations environment assignment)
+ (let ((variable (assignment/variable assignment)))
+ (operations/lookup operations variable
+ (lambda (operation info)
+ info ;ignore
+ (case operation
+ ((INTEGRATE INTEGRATE-OPERATOR EXPAND)
+ (warn "Attempt to assign integrated name"
+ (variable/name variable)))
+ (else (error "Unknown operation" operation))))
+ (lambda () 'DONE))
+ ;; The value of an assignment is the old value
+ ;; of the variable, hence, it is refernced.
+ (variable/reference! variable)
+ (assignment/make (assignment/scode assignment)
+ (assignment/block assignment)
+ variable
+ (integrate/expression operations
+ environment
+ (assignment/value assignment))))))
+
+(define *eager-integration-switch #f)
+
+(define-method/integrate 'REFERENCE
+ (lambda (operations environment expression)
+ (let ((variable (reference/variable expression)))
+ (letrec ((integration-success
+ (lambda (new-expression)
+ (variable/integrated! variable)
+ new-expression))
+ (integration-failure
+ (lambda ()
+ (variable/reference! variable)
+ expression))
+ (try-safe-integration
+ (lambda ()
+ (integrate/name-if-safe expression expression
+ environment operations
+ integration-success
+ integration-failure))))
+ (operations/lookup operations variable
+ (lambda (operation info)
+ (case operation
+ ((INTEGRATE-OPERATOR EXPAND)
+ (variable/reference! variable)
+ expression)
+ ((INTEGRATE)
+ (integrate/name expression expression info environment
+ integration-success integration-failure))
+ ((INTEGRATE-SAFELY)
+ (try-safe-integration))
+ (else
+ (error "Unknown operation" operation))))
+ (lambda ()
+ (if *eager-integration-switch
+ (try-safe-integration)
+ (integration-failure))))))))
+\f
+(define (integrate/name-if-safe expr reference environment
+ operations if-win if-fail)
+ (let ((variable (reference/variable reference)))
+ (if (or (variable/side-effected variable)
+ (not (block/safe? (variable/block variable))))
+ (if-fail)
+ (let ((finish
+ (lambda (value)
+ (if (constant-value? value environment operations)
+ (if-win
+ (reassign
+ expr
+ (copy/expression/intern (reference/block reference)
+ value)))
+ (if-fail)))))
+ (environment/lookup environment variable
+ (lambda (value)
+ (if (delayed-integration? value)
+ (if (delayed-integration/in-progress? value)
+ (if-fail)
+ (finish (delayed-integration/force value)))
+ (finish value)))
+ (lambda () (if-fail))
+ (lambda () (if-fail)))))))
+
+(define (reassign expr object)
+ (if (and expr (object/scode expr))
+ ;; Abstraction violation
+ (with-new-scode (object/scode expr) object)
+ object))
+
+(define (constant-value? value environment operations)
+ (let check ((value value) (top? true))
+ (or (constant? value)
+ (and (reference? value)
+ (or (not top?)
+ (let ((var (reference/variable value)))
+ (and (not (variable/side-effected var))
+ (block/safe? (variable/block var))
+ (environment/lookup environment var
+ (lambda (value*)
+ (check value* false))
+ (lambda ()
+ ;; unknown value
+ (operations/lookup operations var
+ (lambda (operation info)
+ operation info
+ false)
+ (lambda ()
+ ;; No operations
+ true)))
+ (lambda ()
+ ;; not found variable
+ true)))))))))
+\f
+(define (integrate/reference-operator expression operations environment
+ block operator operands)
+ (let ((variable (reference/variable operator)))
+ (letrec ((mark-integrated!
+ (lambda ()
+ (variable/integrated! variable)))
+ (integration-failure
+ (lambda ()
+ (variable/reference! variable)
+ (combination/optimizing-make expression block
+ operator operands)))
+ (integration-success
+ (lambda (operator)
+ (mark-integrated!)
+ (integrate/combination expression operations environment
+ block operator operands)))
+ (try-safe-integration
+ (lambda ()
+ (integrate/name-if-safe expression operator
+ environment operations
+ integration-success
+ integration-failure))))
+ (operations/lookup operations variable
+ (lambda (operation info)
+ (case operation
+ ((#F) (integration-failure))
+ ((INTEGRATE INTEGRATE-OPERATOR)
+ (integrate/name expression
+ operator info environment
+ integration-success
+ integration-failure))
+ ((INTEGRATE-SAFELY)
+ (try-safe-integration))
+ ((EXPAND)
+ (info expression
+ operands
+ (lambda (new-expression)
+ (mark-integrated!)
+ (integrate/expression operations environment
+ new-expression))
+ integration-failure
+ (reference/block operator)))
+ (else
+ (error "Unknown operation" operation))))
+ (lambda ()
+ (if *eager-integration-switch
+ (try-safe-integration)
+ (integration-failure)))))))
+\f
+;;;; Binding
+
+(define (integrate/open-block operations environment expression)
+ (let ((variables (open-block/variables expression))
+ (block (open-block/block expression)))
+ (let ((operations
+ (declarations/bind (operations/shadow operations variables)
+ (block/declarations block))))
+ (process-block-flags (block/flags block)
+ (lambda ()
+ (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
+ (if (open-block/optimized expression)
+ (open-block/make
+ (and expression (object/scode expression))
+ block variables
+ vals actions true)
+ (open-block/optimizing-make
+ expression block variables vals
+ actions operations environment)))))))))))
+
+(define-method/integrate 'OPEN-BLOCK
+ (lambda (operations environment expression)
+ (call-with-values
+ (lambda () (integrate/open-block operations environment expression))
+ (lambda (operations environment expression)
+ operations environment
+ expression))))
+
+(define (process-block-flags flags continuation)
+ (if (null? flags)
+ (continuation)
+ (let ((this-flag (car flags)))
+ (case this-flag
+ ((AUTOMAGIC-INTEGRATIONS)
+ (fluid-let ((*eager-integration-switch #T))
+ (process-block-flags (cdr flags) continuation)))
+ ((NO-AUTOMAGIC-INTEGRATIONS)
+ (fluid-let ((*eager-integration-switch #F))
+ (process-block-flags (cdr flags) continuation)))
+ ((ETA-SUBSTITUTION)
+ (fluid-let ((*eta-substitution-switch #T))
+ (process-block-flags (cdr flags) continuation)))
+ ((NO-ETA-SUBSTITUTION)
+ (fluid-let ((*eta-substitution-switch #F))
+ (process-block-flags (cdr flags) continuation)))
+ ((OPEN-BLOCK-OPTIMIZATIONS)
+ (fluid-let ((*block-optimizing-switch #T))
+ (process-block-flags (cdr flags) continuation)))
+ ((NO-OPEN-BLOCK-OPTIMIZATIONS)
+ (fluid-let ((*block-optimizing-switch #F))
+ (process-block-flags (cdr flags) continuation)))
+ (else (error "Bad flag"))))))
+\f
+(define (variable/unreferenced? variable)
+ (and (not (variable/integrated variable))
+ (not (variable/referenced variable))
+ (not (variable/can-ignore? variable))))
+
+(define-method/integrate 'PROCEDURE
+ (lambda (operations environment procedure)
+ (integrate/procedure operations
+ (simulate-unknown-application environment procedure)
+ procedure)))
+
+;; Cannot optimize (lambda () (bar)) => bar (eta substitution) because
+;; BAR may be a procedure with different arity than the lambda
+
+#| You can get some weird stuff with this
+
+(define (foo x)
+ (define (loop1) (loop2))
+ (define (loop2) (loop3))
+ (define (loop3) (loop1))
+ (bar x))
+
+will optimize into
+
+(define (foo x)
+ (define loop1 loop3)
+ (define loop2 loop3)
+ (define loop3 loop3)
+ (bar x))
+
+and if you have automagic integrations on, this won't finish
+optimizing. Well, you told the machine to loop forever, and it
+determines that it can do this at compile time, so you get what
+you ask for.
+
+|#
+
+(define *eta-substitution-switch #F)
+\f
+(define (integrate/procedure operations environment procedure)
+ (let ((block (procedure/block procedure))
+ (required (procedure/required procedure))
+ (optional (procedure/optional procedure))
+ (rest (procedure/rest procedure)))
+ (fluid-let ((*current-block-names*
+ (cons (procedure/name procedure)
+ *current-block-names*)))
+ (process-block-flags (block/flags block)
+ (lambda ()
+ (let ((body
+ (integrate/expression
+ (declarations/bind
+ (operations/shadow
+ operations
+ (append required optional (if rest (list rest) '())))
+ (block/declarations block))
+ 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))))
+ (if (and *eta-substitution-switch
+ (combination? body)
+ (null? optional)
+ (null? rest)
+ (let ((operands (combination/operands body)))
+ (match-up? operands required))
+ (set/empty?
+ (set/intersection
+ (list->set variable? eq? required)
+ (free/expression (combination/operator body)))))
+ (combination/operator body)
+ (procedure/make (procedure/scode procedure)
+ block
+ (procedure/name procedure)
+ required
+ optional
+ rest
+ body))))))))
+
+(define (match-up? operands required)
+ (if (null? operands)
+ (null? required)
+ (and (not (null? required))
+ (let ((this-operand (car operands))
+ (this-required (car required)))
+ (and (reference? this-operand)
+ (eq? (reference/variable this-operand) this-required)
+ (match-up? (cdr operands) (cdr required)))))))
+\f
+(define-method/integrate 'COMBINATION
+ (lambda (operations environment combination)
+ (integrate/combination
+ combination operations environment
+ (combination/block combination)
+ (combination/operator combination)
+ (integrate/expressions operations
+ environment
+ (combination/operands combination)))))
+
+(define (integrate/combination expression operations environment
+ block operator operands)
+ (cond ((reference? operator)
+ (integrate/reference-operator expression operations environment
+ block operator operands))
+ ((and (access? operator)
+ (system-global-environment? (access/environment operator)))
+ (integrate/access-operator expression operations environment
+ block operator operands))
+ ((and (constant? operator)
+ (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
+ (combination/optimizing-make
+ expression
+ block
+ (if (procedure? operator)
+ (integrate/procedure-operator operations environment
+ block operator operands)
+ (let ((operator
+ (integrate/expression operations environment operator)))
+ (if (procedure? operator)
+ (integrate/procedure-operator operations environment
+ block operator operands)
+ operator)))
+ operands))))
+
+(define (integrate/procedure-operator operations environment
+ block procedure operands)
+ (integrate/procedure operations
+ (simulate-application environment block
+ procedure operands)
+ procedure))
+
+(define (integrate/primitive-operator expression operations environment
+ block operator operands)
+ (let ((integration-failure
+ (lambda ()
+ (combination/optimizing-make expression block operator operands))))
+ (operations/lookup operations (constant/value operator)
+ (lambda (operation info)
+ (case operation
+ ((#F) (integration-failure))
+ ((EXPAND)
+ (info expression
+ operands
+ (lambda (expression)
+ (integrate/expression operations environment expression))
+ integration-failure
+ block))
+ (else (error "Unknown operation" operation))))
+ integration-failure)))
+\f
+(define-method/integrate 'DECLARATION
+ (lambda (operations environment declaration)
+ (let ((declarations (declaration/declarations declaration))
+ (expression (declaration/expression declaration)))
+ (declaration/make
+ (declaration/scode declaration)
+ declarations
+ (integrate/expression (declarations/bind operations declarations)
+ environment
+ expression)))))
+
+;;;; Easy Cases
+
+(define-method/integrate 'CONSTANT
+ (lambda (operations environment expression)
+ operations
+ environment
+ expression))
+
+(define-method/integrate 'THE-ENVIRONMENT
+ (lambda (operations environment expression)
+ operations
+ environment
+ expression))
+
+(define-method/integrate 'QUOTATION
+ (lambda (operations environment expression)
+ operations
+ environment
+ (integrate/quotation expression)))
+
+;; Optimize (if () a b) => b; (if #t a b) => a
+
+(define-method/integrate 'CONDITIONAL
+ (lambda (operations environment expression)
+ (let ((predicate (integrate/expression
+ operations environment
+ (conditional/predicate expression)))
+ (consequent (integrate/expression
+ operations environment
+ (conditional/consequent expression)))
+ (alternative (integrate/expression
+ operations environment
+ (conditional/alternative expression))))
+ (if (constant? predicate)
+ (if (eq? cross-sf/false-value (constant/value predicate))
+ alternative
+ consequent)
+ (conditional/make (conditional/scode expression)
+ predicate consequent alternative)))))
+
+;; Optimize (or () a) => a; (or #t a) => #t
+
+(define-method/integrate 'DISJUNCTION
+ (lambda (operations environment expression)
+ (let ((predicate (integrate/expression operations environment
+ (disjunction/predicate expression)))
+ (alternative (integrate/expression
+ operations environment
+ (disjunction/alternative expression))))
+ (if (constant? predicate)
+ (if (eq? cross-sf/false-value (constant/value predicate))
+ alternative
+ predicate)
+ (disjunction/make (disjunction/scode expression)
+ predicate alternative)))))
+\f
+(define-method/integrate 'SEQUENCE
+ (lambda (operations environment expression)
+ ;; Optimize (begin (foo)) => (foo)
+ ;; Optimize (begin a b (foo) 22 (bar)) => (begin (foo) (bar))
+ (sequence/optimizing-make
+ expression
+ (integrate/actions operations environment
+ (sequence/actions expression)))))
+
+(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 ((reference? action)
+ ;; This clause lets you ignore a variable by
+ ;; mentioning it in a sequence.
+ (variable/can-ignore! (reference/variable action))
+ action)
+ ((eq? action open-block/value-marker)
+ action)
+ (else
+ (integrate/expression operations environment action)))
+ (integrate/actions operations environment (cdr actions))))))
+
+(define (sequence/optimizing-make expression actions)
+ (let ((actions (remove-non-side-effecting actions)))
+ (if (null? (cdr actions))
+ (car actions)
+ (sequence/make (and expression (object/scode expression))
+ actions))))
+
+(define (remove-non-side-effecting actions)
+ ;; Do not remove references from sequences, because they have
+ ;; meaning as declarations. The output code generator will take
+ ;; care of removing them when they are no longer needed.
+ (if (null? (cdr actions))
+ actions
+ (let ((rest (remove-non-side-effecting (cdr actions))))
+ (if (non-side-effecting-in-sequence? (car actions))
+ rest
+ (cons (car actions) rest)))))
+
+(define (non-side-effecting-in-sequence? expression)
+ ;; Compiler does a better job of this because it is smarter about
+ ;; what kinds of expressions can cause side effects. But this
+ ;; should be adequate to catch most of the simple cases.
+ (or (constant? expression)
+ (quotation? expression)
+ (delay? expression)
+ (procedure? expression)
+ (and (access? expression)
+ (non-side-effecting-in-sequence? (access/environment expression)))))
+\f
+(define-method/integrate 'ACCESS
+ (lambda (operations environment expression)
+ (let ((environment* (access/environment expression))
+ (name (access/name expression)))
+ (if (system-global-environment? environment*)
+ (let ((entry (assq name usual-integrations/constant-alist)))
+ (if entry
+ (constant/make (access/scode expression)
+ (constant/value (cdr entry)))
+ (access/make (access/scode expression)
+ environment* name)))
+ (access/make (access/scode expression)
+ (integrate/expression operations environment
+ environment*)
+ name)))))
+
+(define (system-global-environment? expression)
+ (and (constant? expression)
+ (eq? false (constant/value expression))))
+
+(define-method/integrate 'DELAY
+ (lambda (operations environment expression)
+ (delay/make
+ (delay/scode expression)
+ (integrate/expression operations environment
+ (delay/expression expression)))))
+
+(define-method/integrate 'IN-PACKAGE
+ (lambda (operations environment expression)
+ (in-package/make (in-package/scode expression)
+ (integrate/expression operations environment
+ (in-package/environment expression))
+ (integrate/quotation (in-package/quotation expression)))))
+
+(define (integrate/quotation quotation)
+ (call-with-values
+ (lambda ()
+ (integrate/top-level* (quotation/scode quotation)
+ (quotation/block quotation)
+ (quotation/expression quotation)))
+ (lambda (operations environment expression)
+ operations environment ;ignore
+ expression)))
+
+(define (integrate/access-operator expression operations environment
+ block operator operands)
+ (let ((name (access/name operator))
+ (dont-integrate
+ (lambda ()
+ (combination/make (and expression (object/scode expression))
+ block operator operands))))
+ (cond ((and (eq? name 'APPLY)
+ (integrate/hack-apply? operands))
+ => (lambda (operands*)
+ (integrate/combination expression operations environment
+ block (car operands*) (cdr operands*))))
+ ((assq name usual-integrations/constant-alist)
+ => (lambda (entry)
+ (integrate/combination expression operations environment
+ block (cdr entry) operands)))
+ ((assq name usual-integrations/expansion-alist)
+ => (lambda (entry)
+ ((cdr entry) expression operands
+ identity-procedure dont-integrate false)))
+ (else
+ (dont-integrate)))))
+\f
+;;;; Environment
+
+(define (environment/recursive-bind operations environment variables vals)
+ ;; Used to implement mutually-recursive definitions that can
+ ;; 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)))
+ (let ((environment
+ (environment/bind-multiple environment variables vals)))
+ (for-each (lambda (value)
+ (set-delayed-integration/environment! value environment))
+ vals)
+ (values environment (map delayed-integration/force vals)))))
+
+(define (integrate/name expr reference info environment if-integrated if-not)
+ (let ((variable (reference/variable reference)))
+ (let ((finish
+ (lambda (value)
+ (if-integrated
+ (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)
+ (if-not)
+ (finish (delayed-integration/force value)))
+ (finish value)))
+ if-not
+ if-not)))))
+
+(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)))
+ (lambda ()
+ (if-not))
+ (lambda ()
+ (warn "Unable to integrate" (variable/name variable))
+ (if-not))))
+\f
+(define *unknown-value "Unknown Value")
+
+(define (simulate-unknown-application environment procedure)
+ (define (bind-required environment required)
+ (if (null? required)
+ (bind-optional environment (procedure/optional procedure))
+ (bind-required
+ (environment/bind environment (car required) *unknown-value)
+ (cdr required))))
+
+ (define (bind-optional environment optional)
+ (if (null? optional)
+ (bind-rest environment (procedure/rest procedure))
+ (bind-optional
+ (environment/bind environment (car optional) *unknown-value)
+ (cdr optional))))
+
+ (define (bind-rest environment rest)
+ (if (null? rest)
+ environment
+ (environment/bind environment rest *unknown-value)))
+
+ (bind-required environment (procedure/required procedure)))
+
+(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)))))
+
+ (and (not (null? operands))
+ (let ((tail (check (car (last-pair operands)))))
+ (and (not (eq? tail 'FAIL))
+ (append (except-last-pair operands)
+ tail)))))
+\f
+(define (simulate-application environment block procedure operands)
+ (define (procedure->pretty procedure)
+ (if (procedure/scode procedure)
+ (unsyntax (procedure/scode procedure))
+ (let ((arg-list (append (procedure/required procedure)
+ (if (null? (procedure/optional procedure))
+ '()
+ (cons lambda-optional-tag
+ (procedure/optional procedure)))
+ (if (not (procedure/rest procedure))
+ '()
+ (procedure/rest procedure)))))
+ (if (procedure/name procedure)
+ `(named-lambda (,(procedure/name procedure) ,@arg-list)
+ ...)
+ `(lambda ,arg-list
+ ...)))))
+
+ (define (match-required environment required operands)
+ (cond ((null? required)
+ (match-optional environment
+ (procedure/optional procedure)
+ operands))
+ ((null? operands)
+ (error "Too few operands in call to procedure"
+ procedure
+ (procedure->pretty procedure)))
+ (else
+ (match-required (environment/bind environment
+ (car required)
+ (car operands))
+ (cdr required)
+ (cdr operands)))))
+
+ (define (match-optional environment optional operands)
+ (cond ((null? optional)
+ (match-rest environment (procedure/rest procedure) operands))
+ ((null? operands)
+ (match-rest environment (procedure/rest procedure) '()))
+ (else
+ (match-optional (environment/bind environment
+ (car optional)
+ (car operands))
+ (cdr optional)
+ (cdr operands)))))
+
+ (define (listify-tail operands)
+ (let ((const-null (constant/make false '())))
+ (if (null? operands)
+ const-null
+ (let ((const-cons (constant/make false (ucode-primitive cons))))
+ (let walk ((operands operands))
+ (if (null? operands)
+ const-null
+ (combination/make false
+ block
+ const-cons
+ (list (car operands)
+ (walk (cdr operands))))))))))
+
+ (define (match-rest environment rest operands)
+ (cond (rest
+ (environment/bind environment rest (listify-tail operands)))
+ ((null? operands)
+ environment)
+ (else
+ (error "Too many operands in call to procedure"
+ procedure
+ (procedure->pretty procedure)))))
+
+ (match-required environment (procedure/required procedure) operands))
+\f
+(define (environment/make)
+ '())
+
+(define-integrable (environment/bind environment variable value)
+ (cons (cons variable value) environment))
+
+(define-integrable (environment/bind-multiple environment variables values)
+ (map* environment cons variables values))
+
+(define (environment/lookup environment variable if-found if-unknown if-not)
+ (let ((association (assq variable environment)))
+ (if association
+ (if (eq? (cdr association) *unknown-value)
+ (if-unknown)
+ (if-found (cdr association)))
+ (if-not))))
+
+(define (delayed-integration/in-progress? delayed-integration)
+ (eq? (delayed-integration/state delayed-integration) 'BEING-INTEGRATED))
+
+(define (delayed-integration/force delayed-integration)
+ (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 false)
+ (set-delayed-integration/operations! delayed-integration false)
+ (set-delayed-integration/value! delayed-integration false)
+ (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))
+ (else
+ (error "Delayed integration has unknown state"
+ delayed-integration)))
+ (delayed-integration/value delayed-integration))
+\f
+;;;; Optimizations
+
+#|
+Simple LET-like combination. Delete any unreferenced
+parameters. If no parameters remain, delete the
+combination and lambda. Values bound to the unreferenced
+parameters are pulled out of the combination. But integrated
+forms are simply removed.
+
+(define (foo a)
+ (let ((a (+ a 3))
+ (b (bar a))
+ (c (baz a)))
+ (declare (integrate c))
+ (+ c a)))
+
+ ||
+ \/
+
+(define (foo a)
+ (bar a)
+ (let ((a (+ a 3)))
+ (+ (baz a) a)))
+
+|#
+
+(define (foldable-constant? thing)
+ (constant? thing))
+
+(define (foldable-constants? list)
+ (or (null? list)
+ (and (foldable-constant? (car list))
+ (foldable-constants? (cdr list)))))
+
+(define (foldable-constant-value thing)
+ (cond ((constant? thing)
+ (constant/value thing))
+ (else
+ (error "foldable-constant-value: can't happen" thing))))
+
+;;; When cross-sf-ing from a system where () = #f to one where they
+;;; differ, combination/optimizing-make assumes that none of these
+;;; operators can ever return '() (or if they do then it is to be
+;;; interpreted as #f)
+
+(define *foldable-primitive-procedures
+ (map make-primitive-procedure
+ '(OBJECT-TYPE OBJECT-TYPE?
+ NOT EQ? NULL? PAIR? ZERO? POSITIVE? NEGATIVE?
+ &= &< &> &+ &- &* &/ 1+ -1+)))
+
+(define (foldable-operator? operator)
+ (and (constant? operator)
+ (primitive-procedure? (constant/value operator))
+ (memq (constant/value operator) *foldable-primitive-procedures)))
+\f
+;;; deal with (let () (define ...))
+;;; deal with (let ((x 7)) (let ((y 4)) ...)) => (let ((x 7) (y 4)) ...)
+;;; Actually, we really don't want to hack with these for various
+;;; reasons
+
+(define (combination/optimizing-make expression block operator operands)
+ (cond (
+ ;; fold constants
+ (and (foldable-operator? operator)
+ (foldable-constants? operands))
+ (let ((value (apply (constant/value operator)
+ (map foldable-constant-value operands))))
+ (constant/make (and expression (object/scode expression))
+ ;; assumption: no foldable operator returns '()
+ (if value
+ value
+ cross-sf/false-value))))
+
+ (
+ ;; (force (delay x)) ==> x
+ (and (constant? operator)
+ (eq? (constant/value operator) force)
+ (= (length operands) 1)
+ (delay? (car operands)))
+ (delay/expression (car operands)))
+
+ ((and (procedure? operator)
+ (block/safe? (procedure/block operator))
+ (for-all? (procedure/optional operator)
+ variable/integrated)
+ (or (not (procedure/rest operator))
+ (variable/integrated (procedure/rest operator))))
+ (delete-unreferenced-parameters
+ (append (procedure/required operator)
+ (procedure/optional operator))
+ (procedure/rest operator)
+ (procedure/body operator)
+ operands
+ (lambda (required referenced-operands unreferenced-operands)
+ (let ((form
+ (if (and (null? required)
+ ;; need to avoid things like this
+ ;; (foo bar (let () (define (baz) ..) ..))
+ ;; optimizing into
+ ;; (foo bar (define (baz) ..) ..)
+ (not (open-block? (procedure/body operator))))
+ (reassign expression (procedure/body operator))
+ (combination/make
+ (and expression (object/scode expression))
+ block
+ (procedure/make
+ (procedure/scode operator)
+ (procedure/block operator)
+ (procedure/name operator)
+ required
+ '()
+ false
+ (procedure/body operator))
+ referenced-operands))))
+ (if (null? unreferenced-operands)
+ form
+ (sequence/optimizing-make
+ expression
+ (append unreferenced-operands (list form))))))))
+ (else
+ (combination/make (and expression (object/scode expression))
+ block operator operands))))
+\f
+(define (delete-unreferenced-parameters parameters rest body operands receiver)
+ (let ((free-in-body (free/expression body)))
+ (let loop ((parameters parameters)
+ (operands operands)
+ (required-parameters '())
+ (referenced-operands '())
+ (unreferenced-operands '()))
+ (cond ((null? parameters)
+ (if (or rest (null? operands))
+ (receiver (reverse required-parameters) ; preserve order
+ (reverse referenced-operands)
+ (if (or (null? operands)
+ (variable/integrated rest))
+ 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 ((set/member? free-in-body this-parameter)
+ (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))))))))))
+\f
+(define *block-optimizing-switch #f)
+
+;; This is overly hairy, but if it works, no one need know.
+;; What we do is this:
+;; 1 Make a directed graph of the dependencies in an open
+;; block.
+;; 2 Identify the circular dependencies and place them in
+;; a open block.
+;; 3 Identify the bindings that can be made in parallel and
+;; make LET type statements.
+;; 4 This deletes unused bindings in an open block and
+;; compartmentalizes the environment.
+;; 5 Re-optimize the code in the body. This can help if the
+;; eta-substitution-switch is on.
+
+(define (open-block/optimizing-make expression block vars values
+ actions operations environment)
+ (if (and *block-optimizing-switch
+ (block/safe? block))
+ (let ((table:var->vals (associate-vars-and-vals vars values))
+ (bound-variables (varlist->varset vars)))
+ (let ((table:vals->free
+ (get-free-vars-in-bindings bound-variables values))
+ (body-free (get-body-free-vars bound-variables actions)))
+ ;; (write-string "Free vars in body")
+ ;; (display (map variable/name body-free))
+ (let ((graph (build-graph vars
+ table:var->vals
+ table:vals->free
+ body-free)))
+ (collapse-circularities! graph)
+ ;; (print-graph graph)
+ (label-node-depth! graph)
+ (let ((template (linearize graph)))
+ ;; (print-template template)
+ (integrate/expression
+ operations environment
+ (build-new-code expression
+ template
+ (block/parent block)
+ table:var->vals actions))))))
+ (open-block/make
+ (and expression (object/scode expression))
+ block vars values actions #t)))
+
+#|
+(define (print-template template)
+ (if (null? template)
+ '()
+ (let ((this (car template)))
+ (newline)
+ (display (car this))
+ (display (map variable/name (cdr this)))
+ (print-template (cdr template)))))
+|#
+
+(define (associate-vars-and-vals vars vals)
+ (let ((table (make-generic-eq?-table)))
+ (define (fill-table vars vals)
+ (cond ((null? vars) (if (null? vals) '() (error "Mismatch")))
+ ((null? vals) (error "Mismatch"))
+ (else (table-put! table (car vars) (car vals))
+ (fill-table (cdr vars) (cdr vals)))))
+ (fill-table vars vals)
+ table))
+\f
+(declare (integrate varlist->varset nodelist->nodeset
+ empty-nodeset singleton-nodeset
+ empty-varset singleton-varset))
+
+(define (varlist->varset list)
+ (declare (integrate list))
+ (list->set variable? eq? list))
+
+(define (nodelist->nodeset list)
+ (declare (integrate list))
+ (list->set node? eq? list))
+
+(define (empty-nodeset)
+ (empty-set node? eq?))
+
+(define (singleton-nodeset node)
+ (declare (integrate node))
+ (singleton-set node? eq? node))
+
+(define (empty-varset)
+ (declare (integrate node))
+ (empty-set variable? eq?))
+
+(define (singleton-varset variable)
+ (declare (integrate variable))
+ (singleton-set variable? eq? variable))
+
+(define (get-free-vars-in-bindings bound-variables vals)
+ ;; find variables in bindings that are scoped to these
+ ;; bound variables
+ (let ((table (make-generic-eq?-table)))
+ (define (kernel val)
+ (let ((free-variables (free/expression val)))
+ (table-put! table val
+ (set/intersection bound-variables free-variables))))
+ (for-each kernel vals)
+ table))
+
+(define (get-body-free-vars bound-variables actions)
+ (let ((body-forms (get-body actions)))
+ (let loop ((body-forms body-forms)
+ (free (empty-varset)))
+ (if (null? body-forms)
+ free
+ (loop (cdr body-forms)
+ (set/union free
+ (set/intersection bound-variables
+ (free/expression
+ (car body-forms)))))))))
+
+(define (get-body actions)
+ (cond ((null? actions) '())
+ ((eq? (car actions) open-block/value-marker) (get-body (cdr actions)))
+ (else (cons (car actions) (get-body (cdr actions))))))
+\f
+;;; Graph structure for figuring out dependencies in a LETREC
+
+(define-structure (node
+ (constructor %make-node (type vars))
+ (conc-name %node-))
+ type
+ (vars false read-only true)
+ (needs (empty-nodeset))
+ (needed-by (empty-nodeset))
+ (depth false))
+
+(define-integrable (make-base-node)
+ (%make-node 'BASE (empty-varset)))
+
+(define-integrable (variable->node variable)
+ (%make-node 'SETUP (singleton-varset variable)))
+
+(define-integrable (make-letrec-node variable-set)
+ (%make-node 'LETREC variable-set))
+
+(define-integrable (add-node-need! needer what-i-need)
+ (set-%node-needs! needer (set/adjoin (%node-needs needer) what-i-need)))
+
+(define-integrable (remove-node-need! needer what-i-no-longer-need)
+ (set-%node-needs! needer
+ (set/remove (%node-needs needer) what-i-no-longer-need)))
+
+(define-integrable (add-node-needed-by! needee what-needs-me)
+ (set-%node-needed-by! needee
+ (set/adjoin (%node-needed-by needee) what-needs-me)))
+
+(define-integrable (remove-node-needed-by! needee what-needs-me)
+ (set-%node-needed-by! needee
+ (set/remove (%node-needed-by needee) what-needs-me)))
+\f
+(define (build-graph vars table:var->vals table:vals->free body-free)
+ (let ((table:variable->node (make-generic-eq?-table)))
+
+ (define (kernel variable)
+ (let ((node (variable->node variable)))
+ (table-put! table:variable->node variable node)))
+
+ (for-each kernel vars)
+
+ (link-nodes! body-free table:var->vals table:vals->free vars
+ table:variable->node)))
+
+(define-integrable (link-2-nodes! from-node to-node)
+ (add-node-need! from-node to-node)
+ (add-node-needed-by! to-node from-node))
+
+(define (unlink-node! node)
+ (set/for-each (lambda (needer)
+ (remove-node-needed-by! needer node))
+ (%node-needs node))
+ (set/for-each (lambda (needee)
+ (remove-node-need! needee node))
+ (%node-needed-by node))
+ (set-%node-type! node 'UNLINKED))
+
+(define-integrable (unlink-nodes! nodelist)
+ (for-each unlink-node! nodelist))
+
+(define (link-nodes! body-free
+ table:var->vals table:vals->free variables table:var->node)
+
+ (define (kernel variable)
+ (table-get table:var->node variable
+ (lambda (node)
+ (table-get-chain variable
+ (lambda (free-vars)
+ (set/for-each
+ (lambda (needed-var)
+ (table-get table:var->node needed-var
+ (lambda (needed-node)
+ (link-2-nodes! node needed-node))
+ (lambda ()
+ (error "Broken analysis: can't get node"))))
+ free-vars))
+ (lambda () (error "Broken analysis: can't get free variable info"))
+ table:var->vals table:vals->free))
+ (lambda () (error "Broken analysis: no node for variable"))))
+
+ (for-each kernel variables)
+
+ (let ((base-node (make-base-node)))
+ (set/for-each
+ (lambda (needed-var)
+ (table-get table:var->node needed-var
+ (lambda (needed-node)
+ (link-2-nodes! base-node needed-node))
+ (lambda () (error "Broken analysis: free var"))))
+ body-free)
+ base-node))
+\f
+(define (collapse-circularities! graph)
+ ;; Search for a circularity: if found, collapse it, and repeat
+ ;; until none are found.
+ (define (loop)
+ (find-circularity graph
+ (lambda (nodelist)
+ (collapse-nodelist! nodelist)
+ (loop))
+ (lambda () graph)))
+ (loop))
+
+(define (find-circularity graph if-found if-not)
+ ;; Walk the tree keeping track of nodes visited
+ ;; If a node is encountered more than once, there is
+ ;; a circularitiy. NODES-VISITED is a list kept in
+ ;; base node first order. If a node is found on the
+ ;; list, the tail of the list is the nodes in the
+ ;; circularity.
+
+ (define (fc this-node nodes-visited if-found if-not)
+ (if (null? this-node)
+ (if-not)
+ (let ((circularity (memq this-node nodes-visited)))
+ (if circularity
+ (if-found circularity)
+ ;; Add this node to the visited list, and loop
+ ;; over the needs of this node.
+ (let ((new-visited (append nodes-visited (list this-node))))
+ (let loop ((needs (set->list (%node-needs this-node))))
+ (if (null? needs)
+ (if-not)
+ (fc (car needs) new-visited if-found
+ (lambda () (loop (cdr needs)))))))))))
+
+ (fc graph '() if-found if-not))
+
+(define (collapse-nodelist! nodelist)
+ ;; Replace the nodes in the nodelist with a single node that
+ ;; has all the variables in it. This node will become a LETREC
+ ;; form.
+
+ ;; Error check: make sure graph is consistant.
+ (for-each (lambda (node) (if (eq? (%node-type node) 'UNLINKED)
+ (error "node not linked")))
+ nodelist)
+
+ (let ((nodeset (nodelist->nodeset nodelist)))
+ (let ((varset (apply set/union* (map %node-vars nodelist)))
+ (needs-set (set/difference
+ (apply set/union* (map %node-needs nodelist))
+ nodeset))
+ (needed-by (set/difference
+ (apply set/union* (map %node-needed-by nodelist))
+ nodeset)))
+
+ (let ((letrec-node (make-letrec-node varset)))
+ (set/for-each (lambda (need) (link-2-nodes! letrec-node need))
+ needs-set)
+ (set/for-each
+ (lambda (needer) (link-2-nodes! needer letrec-node)) needed-by)
+ ;; now delete nodes in nodelist
+ (unlink-nodes! nodelist)))))
+\f
+(define (label-node-depth! graph)
+ (define (label-nodes! nodeset depth)
+ (if (set/empty? nodeset)
+ '()
+ (begin
+ (set/for-each (lambda (node) (set-%node-depth! node depth)) nodeset)
+ (label-nodes!
+ (apply set/union* (map %node-needs (set->list nodeset)))
+ (1+ depth)))))
+ (label-nodes! (singleton-nodeset graph) 0))
+
+#|
+(define (print-graph node)
+ (if (null? node)
+ '()
+ (begin
+ (newline)
+ (display (%node-depth node))
+ (display (%node-type node))
+ (set/for-each (lambda (variable)
+ (display " ")
+ (display (variable/name variable)))
+ (%node-vars node))
+ (set/for-each print-graph (%node-needs node)))))
+|#
+
+(define (collapse-parallel-nodelist depth nodeset)
+ (if (set/empty? nodeset)
+ '()
+ (let loop ((nodestream (set->list nodeset))
+ (let-children (empty-varset))
+ (letrec-children (empty-varset))
+ (children (empty-nodeset)))
+ (if (null? nodestream)
+ (let ((outer-contour
+ (collapse-parallel-nodelist (1+ depth) children)))
+ (append (if (set/empty? let-children)
+ '()
+ (list (cons 'LET (set->list let-children))))
+ (if (set/empty? letrec-children)
+ '()
+ (list (cons 'LETREC (set->list letrec-children))))
+ outer-contour))
+ (let ((this-node (car nodestream)))
+ (if (= (%node-depth this-node) (1+ depth))
+ (if (eq? (%node-type this-node) 'LETREC)
+ (loop (cdr nodestream)
+ let-children
+ (set/union (%node-vars this-node) letrec-children)
+ (set/union (%node-needs this-node) children))
+ (loop (cdr nodestream)
+ (set/union (%node-vars this-node) let-children)
+ letrec-children
+ (set/union (%node-needs this-node) children)))
+ ;; deeper nodes will be picked up later
+ (loop (cdr nodestream)
+ let-children
+ letrec-children
+ children)))))))
+\f
+(define (linearize graph)
+ (collapse-parallel-nodelist 0 (%node-needs graph)))
+
+(define (build-new-code expression template parent vars->vals actions)
+ (let ((body (sequence/optimizing-make expression (get-body actions))))
+ (let loop ((template template)
+ (block parent)
+ (code body))
+ (if (null? template)
+ code
+ (let ((this (car template)))
+ (let ((this-type (car this))
+ (this-vars (cdr this)))
+ (let ((this-vals
+ (map (lambda (var)
+ (table-get vars->vals var
+ (lambda (val) val)
+ (lambda () (error "broken"))))
+ this-vars)))
+
+ (if (eq? this-type 'LET)
+ (let ((block (block/make block true this-vars)))
+ (loop (cdr template)
+ block
+ (combination/optimizing-make
+ expression
+ block
+ (procedure/make
+ false
+ block
+ lambda-tag:let
+ this-vars
+ '()
+ false
+ code)
+ this-vals)))
+ (let ((block (block/make block true this-vars)))
+ (loop (cdr template)
+ block
+ (open-block/make
+ (and expression (object/scode expression))
+ block this-vars this-vals
+ (append (make-list
+ (length this-vals)
+ open-block/value-marker)
+ (list code))
+ #t)))))))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: usicon.scm,v 1.1 1995/03/07 22:16:32 adams Exp $
+
+Copyright (c) 1987-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Optimizer: Usual Integrations: Constants
+;;; package: (scode-optimizer)
+
+(declare (usual-integrations)
+ (integrate-external "object"))
+\f
+(define usual-integrations/constant-names)
+(define usual-integrations/constant-values)
+(define usual-integrations/constant-alist)
+(define usual-integrations/constant-alist-names*values)
+
+(define (usual-integrations/delete-constant! name)
+ (set! global-constant-objects (delq! name global-constant-objects))
+ (usual-integrations/cache!))
+
+(define (usual-integrations/cache!)
+ (set! usual-integrations/constant-names
+ (list-copy global-constant-objects))
+ (set! usual-integrations/constant-values
+ (map (lambda (name)
+ (let ((object
+ (lexical-reference system-global-environment name)))
+ (if (not (memq (microcode-type/code->name
+ (object-type object))
+ '(BIGNUM
+ CHARACTER
+ POSITIVE-FIXNUM NEGATIVE-FIXNUM FIXNUM
+ FLONUM
+ INTERNED-SYMBOL
+ NULL
+ PAIR
+ PRIMITIVE
+ QUAD
+ RATNUM
+ RECNUM
+ RETURN-CODE
+ STRING
+ TRIPLE
+ CONSTANT TRUE
+ UNINTERNED-SYMBOL
+ VECTOR
+ VECTOR-16B
+ VECTOR-1B)))
+ (error "USUAL-INTEGRATIONS: not a constant" name))
+ (constant->integration-info object)))
+ usual-integrations/constant-names))
+ (set! usual-integrations/constant-alist
+ (map (lambda (name)
+ (cons name
+ (constant/make
+ false
+ (lexical-reference system-global-environment name))))
+ usual-integrations/constant-names))
+ (set! usual-integrations/constant-alist-names*values
+ (map cons usual-integrations/constant-names
+ usual-integrations/constant-values))
+ 'DONE)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: usiexp.scm,v 1.1 1995/03/07 22:19:00 adams Exp $
+
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Optimizer: Usual Integrations: Combination Expansions
+;;; package: (scode-optimizer expansion)
+
+(declare (usual-integrations)
+ (integrate-external "object"))
+\f
+(define (usual-integrations/make-expansion-alist)
+
+ ;; This procedure is huge.
+ ;; At the bottom it returns a list of expansions
+
+
+ ;;;; Fixed-arity arithmetic primitives
+
+ (define (make-combination expression block primitive operands)
+ (combination/make (and expression
+ (object/scode expression))
+ block
+ (constant/make false primitive)
+ operands))
+
+ (define (constant-eq? expression constant)
+ (and (constant? expression)
+ (eq? (constant/value expression) constant)))
+
+ (define (unary-arithmetic primitive)
+ (lambda (expr operands if-expanded if-not-expanded block)
+ (if (and (pair? operands)
+ (null? (cdr operands)))
+ (if-expanded (make-combination expr block primitive operands))
+ (if-not-expanded))))
+
+ (define (binary-arithmetic primitive)
+ (lambda (expr operands if-expanded if-not-expanded block)
+ (if (and (pair? operands)
+ (pair? (cdr operands))
+ (null? (cddr operands)))
+ (if-expanded (make-combination expr block primitive operands))
+ (if-not-expanded))))
+
+ (define zero?-expansion
+ (unary-arithmetic (ucode-primitive zero?)))
+
+ (define positive?-expansion
+ (unary-arithmetic (ucode-primitive positive?)))
+
+ (define negative?-expansion
+ (unary-arithmetic (ucode-primitive negative?)))
+
+ (define 1+-expansion
+ (unary-arithmetic (ucode-primitive 1+)))
+
+ (define -1+-expansion
+ (unary-arithmetic (ucode-primitive -1+)))
+
+ (define quotient-expansion
+ (binary-arithmetic (ucode-primitive quotient 2)))
+
+ (define remainder-expansion
+ (binary-arithmetic (ucode-primitive remainder 2)))
+
+ (define modulo-expansion
+ (binary-arithmetic (ucode-primitive modulo 2)))
+\f
+ ;;;; N-ary Arithmetic Predicates
+
+ (define (pairwise-test binary-predicate if-left-zero if-right-zero)
+ (lambda (expr operands if-expanded if-not-expanded block)
+ (if (and (pair? operands)
+ (pair? (cdr operands))
+ (null? (cddr operands)))
+ (if-expanded
+ (cond ((constant-eq? (car operands) 0)
+ (make-combination expr block if-left-zero
+ (list (cadr operands))))
+ ((constant-eq? (cadr operands) 0)
+ (make-combination expr block if-right-zero
+ (list (car operands))))
+ (else
+ (make-combination expr block binary-predicate operands))))
+ (if-not-expanded))))
+
+ (define (pairwise-test-inverse inverse-expansion)
+ (lambda (expr operands if-expanded if-not-expanded block)
+ (inverse-expansion
+ expr operands
+ (lambda (expression)
+ (if-expanded
+ (make-combination expr block (ucode-primitive not)
+ (list expression))))
+ if-not-expanded
+ block)))
+
+ (define =-expansion
+ (pairwise-test (ucode-primitive &=)
+ (ucode-primitive zero?)
+ (ucode-primitive zero?)))
+
+ (define <-expansion
+ (pairwise-test (ucode-primitive &<)
+ (ucode-primitive positive?)
+ (ucode-primitive negative?)))
+
+ (define >-expansion
+ (pairwise-test (ucode-primitive &>)
+ (ucode-primitive negative?)
+ (ucode-primitive positive?)))
+
+ (define <=-expansion (pairwise-test-inverse >-expansion))
+ (define >=-expansion (pairwise-test-inverse <-expansion))
+\f
+ ;;;; Fixnum Operations
+
+ (define (fix:zero?-expansion expr operands if-expanded if-not-expanded block)
+ (if (and (pair? operands) (null? (cdr operands)))
+ (if-expanded
+ (make-combination expr block (ucode-primitive eq?)
+ (list (car operands) (constant/make false 0))))
+ (if-not-expanded)))
+
+ (define (fix:=-expansion expr operands if-expanded if-not-expanded block)
+ (if (and (pair? operands)
+ (pair? (cdr operands))
+ (null? (cddr operands)))
+ (if-expanded
+ (make-combination expr block (ucode-primitive eq?) operands))
+ (if-not-expanded)))
+
+ (define char=?-expansion
+ fix:=-expansion)
+
+ (define (fix:<=-expansion expr operands if-expanded if-not-expanded block)
+ (if (and (pair? operands)
+ (pair? (cdr operands))
+ (null? (cddr operands)))
+ (if-expanded
+ (make-combination
+ expr
+ block
+ (ucode-primitive not)
+ (list (make-combination false
+ block
+ (ucode-primitive greater-than-fixnum?)
+ operands))))
+ (if-not-expanded)))
+
+ (define (fix:>=-expansion expr operands if-expanded if-not-expanded block)
+ (if (and (pair? operands)
+ (pair? (cdr operands))
+ (null? (cddr operands)))
+ (if-expanded
+ (make-combination
+ expr
+ block
+ (ucode-primitive not)
+ (list (make-combination false
+ block
+ (ucode-primitive less-than-fixnum?)
+ operands))))
+ (if-not-expanded)))
+\f
+ ;;;; N-ary Arithmetic Field Operations
+
+ (define (right-accumulation identity make-binary)
+ (lambda (expr operands if-expanded if-not-expanded block)
+ (let ((operands (delq identity operands)))
+ (let ((n (length operands)))
+ (cond ((zero? n)
+ (if-expanded (constant/make
+ (and expr (object/scode expr));;?
+ identity)))
+ ((< n 5)
+ (if-expanded
+ (let loop
+ ((expr expr)
+ (first (car operands))
+ (rest (cdr operands)))
+ (if (null? rest)
+ first
+ (make-binary expr
+ block
+ first
+ (loop false (car rest) (cdr rest)))))))
+ (else
+ (if-not-expanded)))))))
+
+ (define +-expansion
+ (right-accumulation
+ 0
+ (lambda (expr block x y)
+ (cond ((constant-eq? x 1)
+ (make-combination expr block (ucode-primitive 1+) (list y)))
+ ((constant-eq? y 1)
+ (make-combination expr block (ucode-primitive 1+) (list x)))
+ (else
+ (make-combination expr block (ucode-primitive &+) (list x y)))))))
+
+ (define *-expansion
+ (right-accumulation
+ 1
+ (lambda (expr block x y)
+ (make-combination expr block (ucode-primitive &*) (list x y)))))
+\f
+ #|
+ (define (expt-expansion expr operands if-expanded if-not-expanded block)
+ (let ((make-binder
+ (lambda (make-body)
+ (if-expanded
+ (combination/make
+ (and expr (object/scode expr))
+ block
+ (let ((block (block/make block #t '()))
+ (name (string->uninterned-symbol "operand")))
+ (let ((variable (variable/make&bind! block name)))
+ (procedure/make
+ #f
+ block lambda-tag:let (list variable) '() #f
+ (make-body block (reference/make false block variable)))))
+ (list (car operands)))))))
+ (cond ((not (and (pair? operands)
+ (pair? (cdr operands))
+ (null? (cddr operands))))
+ (if-not-expanded))
+ ;;((constant-eq? (cadr operands) 0)
+ ;; (if-expanded (constant/make (and expr (object/scode expr)) 1)))
+ ((constant-eq? (cadr operands) 1)
+ (if-expanded (car operands)))
+ ((constant-eq? (cadr operands) 2)
+ (make-binder
+ (lambda (block operand)
+ (make-combination #f
+ block
+ (ucode-primitive &*)
+ (list operand operand)))))
+ ((constant-eq? (cadr operands) 3)
+ (make-binder
+ (lambda (block operand)
+ (make-combination
+ #f
+ block
+ (ucode-primitive &*)
+ (list operand
+ (make-combination #f
+ block
+ (ucode-primitive &*)
+ (list operand operand)))))))
+ ((constant-eq? (cadr operands) 4)
+ (make-binder
+ (lambda (block operand)
+ (make-combination
+ #f
+ block
+ (ucode-primitive &*)
+ (list (make-combination #f
+ block
+ (ucode-primitive &*)
+ (list operand operand))
+ (make-combination #f
+ block
+ (ucode-primitive &*)
+ (list operand operand)))))))
+ (else
+ (if-not-expanded)))))
+ |#
+\f
+ (define (right-accumulation-inverse identity inverse-expansion make-binary)
+ (lambda (expr operands if-expanded if-not-expanded block)
+ (let ((expand
+ (lambda (expr x y)
+ (if-expanded
+ (if (constant-eq? y identity)
+ x
+ (make-binary expr block x y))))))
+ (cond ((null? operands)
+ (if-not-expanded))
+ ((null? (cdr operands))
+ (expand expr (constant/make false identity) (car operands)))
+ (else
+ (inverse-expansion false (cdr operands)
+ (lambda (expression)
+ (expand expr (car operands) expression))
+ if-not-expanded
+ block))))))
+
+ (define --expansion
+ (right-accumulation-inverse
+ 0
+ +-expansion
+ (lambda (expr block x y)
+ (if (constant-eq? y 1)
+ (make-combination expr block (ucode-primitive -1+) (list x))
+ (make-combination expr block (ucode-primitive &-) (list x y))))))
+
+ (define /-expansion
+ (right-accumulation-inverse
+ 1
+ *-expansion
+ (lambda (expr block x y)
+ (make-combination expr block (ucode-primitive &/) (list x y)))))
+\f
+ ;;;; N-ary List Operations
+
+ (define (apply*-expansion expr operands if-expanded if-not-expanded block)
+ (if (< 1 (length operands) 10)
+ (if-expanded
+ (combination/make
+ (and expr (object/scode expr))
+ block
+ (global-ref/make 'APPLY)
+ (list (car operands)
+ (cons*-expansion-loop false block (cdr operands)))))
+ (if-not-expanded)))
+
+ (define (cons*-expansion expr operands if-expanded if-not-expanded block)
+ (if (< -1 (length operands) 9)
+ (if-expanded (cons*-expansion-loop expr block operands))
+ (if-not-expanded)))
+
+ (define (cons*-expansion-loop expr block rest)
+ (if (null? (cdr rest))
+ (car rest)
+ (make-combination expr
+ block
+ (ucode-primitive cons)
+ (list (car rest)
+ (cons*-expansion-loop false block (cdr rest))))))
+
+ (define (list-expansion expr operands if-expanded if-not-expanded block)
+ (if (< (length operands) 9)
+ (if-expanded (list-expansion-loop expr block operands))
+ (if-not-expanded)))
+
+ (define (list-expansion-loop expr block rest)
+ (if (null? rest)
+ (constant/make (and expr (object/scode expr)) '())
+ (make-combination expr block (ucode-primitive cons)
+ (list (car rest)
+ (list-expansion-loop false block (cdr rest))))))
+
+ (define (values-expansion expr operands if-expanded if-not-expanded block)
+ if-not-expanded
+ (if-expanded
+ (let ((block (block/make block true '())))
+ (let ((variables
+ (map (lambda (operand)
+ operand
+ (variable/make&bind! block
+ (string->uninterned-symbol "value")))
+ operands)))
+ (combination/make
+ (and expr (object/scode expr))
+ block
+ (procedure/make
+ false
+ block lambda-tag:let variables '() false
+ (let ((block (block/make block true '())))
+ (let ((variable (variable/make&bind! block 'RECEIVER)))
+ (procedure/make
+ false block lambda-tag:unnamed (list variable) '() false
+ (combination/make false
+ block
+ (reference/make false block variable)
+ (map (lambda (variable)
+ (reference/make false block variable))
+ variables))))))
+ operands)))))
+
+ (define (call-with-values-expansion expr operands
+ if-expanded if-not-expanded block)
+ (if (and (pair? operands)
+ (pair? (cdr operands))
+ (null? (cddr operands)))
+ (if-expanded
+ (combination/make (and expr (object/scode expr))
+ block
+ (combination/make false block (car operands) '())
+ (cdr operands)))
+ (if-not-expanded)))
+\f
+ ;;;; General CAR/CDR Encodings
+
+ (define (general-car-cdr-expansion encoding)
+ (lambda (expr operands if-expanded if-not-expanded block)
+ (if (= (length operands) 1)
+ (if-expanded
+ (make-combination expr
+ block
+ (ucode-primitive general-car-cdr)
+ (list (car operands)
+ (constant/make false encoding))))
+ (if-not-expanded))))
+
+ (define caar-expansion (general-car-cdr-expansion #b111))
+ (define cadr-expansion (general-car-cdr-expansion #b110))
+ (define cdar-expansion (general-car-cdr-expansion #b101))
+ (define cddr-expansion (general-car-cdr-expansion #b100))
+
+ (define caaar-expansion (general-car-cdr-expansion #b1111))
+ (define caadr-expansion (general-car-cdr-expansion #b1110))
+ (define cadar-expansion (general-car-cdr-expansion #b1101))
+ (define caddr-expansion (general-car-cdr-expansion #b1100))
+ (define cdaar-expansion (general-car-cdr-expansion #b1011))
+ (define cdadr-expansion (general-car-cdr-expansion #b1010))
+ (define cddar-expansion (general-car-cdr-expansion #b1001))
+ (define cdddr-expansion (general-car-cdr-expansion #b1000))
+
+ (define caaaar-expansion (general-car-cdr-expansion #b11111))
+ (define caaadr-expansion (general-car-cdr-expansion #b11110))
+ (define caadar-expansion (general-car-cdr-expansion #b11101))
+ (define caaddr-expansion (general-car-cdr-expansion #b11100))
+ (define cadaar-expansion (general-car-cdr-expansion #b11011))
+ (define cadadr-expansion (general-car-cdr-expansion #b11010))
+ (define caddar-expansion (general-car-cdr-expansion #b11001))
+ (define cadddr-expansion (general-car-cdr-expansion #b11000))
+ (define cdaaar-expansion (general-car-cdr-expansion #b10111))
+ (define cdaadr-expansion (general-car-cdr-expansion #b10110))
+ (define cdadar-expansion (general-car-cdr-expansion #b10101))
+ (define cdaddr-expansion (general-car-cdr-expansion #b10100))
+ (define cddaar-expansion (general-car-cdr-expansion #b10011))
+ (define cddadr-expansion (general-car-cdr-expansion #b10010))
+ (define cdddar-expansion (general-car-cdr-expansion #b10001))
+ (define cddddr-expansion (general-car-cdr-expansion #b10000))
+
+ (define first-expansion (general-car-cdr-expansion #b11))
+ (define second-expansion cadr-expansion)
+ (define third-expansion caddr-expansion)
+ (define fourth-expansion cadddr-expansion)
+ (define fifth-expansion (general-car-cdr-expansion #b110000))
+ (define sixth-expansion (general-car-cdr-expansion #b1100000))
+ (define seventh-expansion (general-car-cdr-expansion #b11000000))
+ (define eighth-expansion (general-car-cdr-expansion #b110000000))
+\f
+ ;;;; Miscellaneous
+
+ (define (make-string-expansion expr operands if-expanded if-not-expanded block)
+ (if (and (pair? operands)
+ (null? (cdr operands)))
+ (if-expanded
+ (make-combination expr block (ucode-primitive string-allocate)
+ operands))
+ (if-not-expanded)))
+
+ (define (type-test-expansion type)
+ (lambda (expr operands if-expanded if-not-expanded block)
+ (if (and (pair? operands)
+ (null? (cdr operands)))
+ (if-expanded (make-type-test expr block type (car operands)))
+ (if-not-expanded))))
+
+ (define (disjunction-type-test-expansion get-the-types)
+ (lambda (expr operands if-expanded if-not-expanded block)
+ (if (and (pair? operands)
+ (null? (cdr operands)))
+ (if-expanded
+ (make-disjunction
+ expr
+ (map (lambda (type)
+ (make-type-test false block type (car operands)))
+ get-the-types)))
+ (if-not-expanded))))
+
+ (define char?-expansion
+ (type-test-expansion (cross-sf/ucode-type 'character)))
+ (define cell?-expansion
+ (type-test-expansion (cross-sf/ucode-type 'cell)))
+ (define vector?-expansion
+ (type-test-expansion (cross-sf/ucode-type 'vector)))
+ (define %record?-expansion
+ (type-test-expansion (cross-sf/ucode-type 'record)))
+ (define weak-pair?-expansion
+ (type-test-expansion (cross-sf/ucode-type 'weak-cons)))
+ (define flo:flonum?-expansion
+ (type-test-expansion (cross-sf/ucode-type 'big-flonum)))
+
+ (define fixnum-ucode-types
+ (let ((-ve (cross-sf/ucode-type 'negative-fixnum))
+ (+0ve (cross-sf/ucode-type 'positive-fixnum)))
+ (if (= -ve +0ve)
+ (list +0ve)
+ (list +0ve -ve))))
+
+ (define fix:fixnum?-expansion
+ (disjunction-type-test-expansion fixnum-ucode-types))
+
+ (define exact-integer?-expansion
+ (disjunction-type-test-expansion
+ (append fixnum-ucode-types (list (cross-sf/ucode-type 'big-fixnum)))))
+
+ (define exact-rational?-expansion
+ (disjunction-type-test-expansion
+ (append fixnum-ucode-types (list (cross-sf/ucode-type 'big-fixnum)
+ (cross-sf/ucode-type 'ratnum)))))
+
+ (define complex?-expansion
+ (disjunction-type-test-expansion
+ (append fixnum-ucode-types (list (cross-sf/ucode-type 'big-fixnum)
+ (cross-sf/ucode-type 'ratnum)
+ (cross-sf/ucode-type 'big-flonum)
+ (cross-sf/ucode-type 'recnum)))))
+\f
+ (define (make-disjunction expr clauses)
+ (let loop ((clauses clauses))
+ (if (null? (cdr clauses))
+ (car clauses)
+ (disjunction/make (and expr (object/scode expr))
+ (car clauses) (loop (cdr clauses))))))
+
+ (define (make-type-test expr block type operand)
+ (make-combination expr block
+ (ucode-primitive object-type?)
+ (list (constant/make false type) operand)))
+
+ (define (string->symbol-expansion expr operands if-expanded if-not-expanded
+ block)
+ block
+ (if (and (pair? operands)
+ (string? (car operands))
+ (null? (cdr operands)))
+ (if-expanded
+ (constant/make (and expr (object/scode expr))
+ (string->symbol (car operands))))
+ (if-not-expanded)))
+
+ (define (int:->flonum-expansion expr operands if-expanded if-not-expanded
+ block)
+ (if (and (pair? operands)
+ (null? (cdr operands)))
+ (if-expanded
+ (make-combination expr
+ block
+ (ucode-primitive integer->flonum 2)
+ (list (car operands) (constant/make #f #b10))))
+ (if-not-expanded)))
+\f
+ (define usual-integrations/expansion-alist
+ `((%record? . ,%record?-expansion)
+ (* . ,*-expansion)
+ (+ . ,+-expansion)
+ (- . ,--expansion)
+ (-1+ . ,-1+-expansion)
+ (/ . ,/-expansion)
+ (1+ . ,1+-expansion)
+ (< . ,<-expansion)
+ (<= . ,<=-expansion)
+ (= . ,=-expansion)
+ (> . ,>-expansion)
+ (>= . ,>=-expansion)
+ (apply* . ,apply*-expansion)
+ (caaaar . ,caaaar-expansion)
+ (caaadr . ,caaadr-expansion)
+ (caaar . ,caaar-expansion)
+ (caadar . ,caadar-expansion)
+ (caaddr . ,caaddr-expansion)
+ (caadr . ,caadr-expansion)
+ (caar . ,caar-expansion)
+ (cadaar . ,cadaar-expansion)
+ (cadadr . ,cadadr-expansion)
+ (cadar . ,cadar-expansion)
+ (caddar . ,caddar-expansion)
+ (cadddr . ,cadddr-expansion)
+ (caddr . ,caddr-expansion)
+ (cadr . ,cadr-expansion)
+ (call-with-values . ,call-with-values-expansion)
+ (cdaaar . ,cdaaar-expansion)
+ (cdaadr . ,cdaadr-expansion)
+ (cdaar . ,cdaar-expansion)
+ (cdadar . ,cdadar-expansion)
+ (cdaddr . ,cdaddr-expansion)
+ (cdadr . ,cdadr-expansion)
+ (cdar . ,cdar-expansion)
+ (cddaar . ,cddaar-expansion)
+ (cddadr . ,cddadr-expansion)
+ (cddar . ,cddar-expansion)
+ (cdddar . ,cdddar-expansion)
+ (cddddr . ,cddddr-expansion)
+ (cdddr . ,cdddr-expansion)
+ (cddr . ,cddr-expansion)
+ (cell? . ,cell?-expansion)
+ (char=? . ,char=?-expansion)
+ (char? . ,char?-expansion)
+ (complex? . ,complex?-expansion)
+ (cons* . ,cons*-expansion)
+ (eighth . ,eighth-expansion)
+ (exact-integer? . ,exact-integer?-expansion)
+ (exact-rational? . ,exact-rational?-expansion)
+ ;;(expt . ,expt-expansion)
+ (fifth . ,fifth-expansion)
+ (first . ,first-expansion)
+ (fix:<= . ,fix:<=-expansion)
+ (fix:= . ,fix:=-expansion)
+ (fix:>= . ,fix:>=-expansion)
+ ;;(fix:fixnum? . ,fix:fixnum?-expansion)
+ (fix:zero? . ,fix:zero?-expansion)
+ (flo:flonum? . ,flo:flonum?-expansion)
+ (fourth . ,fourth-expansion)
+ (int:->flonum . ,int:->flonum-expansion)
+ (exact-integer? . ,exact-integer?-expansion)
+ (list . ,list-expansion)
+ (make-string . ,make-string-expansion)
+ ;;(modulo . ,modulo-expansion)
+ (negative? . ,negative?-expansion)
+ (complex? . ,complex?-expansion)
+ (positive? . ,positive?-expansion)
+ (quotient . ,quotient-expansion)
+ (remainder . ,remainder-expansion)
+ (second . ,second-expansion)
+ (seventh . ,seventh-expansion)
+ (sixth . ,sixth-expansion)
+ (string->symbol . ,string->symbol-expansion)
+ (third . ,third-expansion)
+ (values . ,values-expansion)
+ (vector? . ,vector?-expansion)
+ (weak-pair? . ,weak-pair?-expansion)
+ (call-with-values . ,call-with-values-expansion)
+ (zero? . ,zero?-expansion)
+ ))
+
+ usual-integrations/expansion-alist)
+\f
+(define usual-integrations/expansion-alist)
+
+(define (usual-integrations/initialize-expanders!)
+ (set! usual-integrations/expansion-alist
+ (usual-integrations/make-expansion-alist)))
+\f
+;;;; Hooks and utilities for user defined reductions and expanders
+
+;;; User defined reductions appear in reduct.scm
+
+;;; Scode->Scode expanders
+
+(define (scode->scode-expander scode-expander)
+ (lambda (expr operands if-expanded if-not-expanded block)
+ (scode-expander
+ (map cgen/external-with-declarations operands)
+ (lambda (scode-expression)
+ (if-expanded
+ (reassign
+ expr
+ (transform/recursive
+ block
+ (integrate/get-top-level-block)
+ scode-expression))))
+ if-not-expanded)))
+
+;;; Kludge for EXPAND-OPERATOR declaration.
+(define expander-evaluation-environment
+ (the-environment))
\ No newline at end of file
projects / mit-scheme.git / commitdiff