From 7032c1e8715c52753ea570a8e1fa4174e71860fb Mon Sep 17 00:00:00 2001 From: Stephen Adams Date: Tue, 7 Mar 1995 22:21:02 +0000 Subject: [PATCH] Initial revision --- v8/src/sf/cross.scm | 130 ++++ v8/src/sf/gconst.scm | 290 +++++++++ v8/src/sf/pardec.scm | 490 ++++++++++++++ v8/src/sf/sf.pkg | 183 ++++++ v8/src/sf/subst.scm | 1460 ++++++++++++++++++++++++++++++++++++++++++ v8/src/sf/usicon.scm | 91 +++ v8/src/sf/usiexp.scm | 682 ++++++++++++++++++++ 7 files changed, 3326 insertions(+) create mode 100644 v8/src/sf/cross.scm create mode 100644 v8/src/sf/gconst.scm create mode 100644 v8/src/sf/pardec.scm create mode 100644 v8/src/sf/sf.pkg create mode 100644 v8/src/sf/subst.scm create mode 100644 v8/src/sf/usicon.scm create mode 100644 v8/src/sf/usiexp.scm diff --git a/v8/src/sf/cross.scm b/v8/src/sf/cross.scm new file mode 100644 index 000000000..4aca0bd2e --- /dev/null +++ b/v8/src/sf/cross.scm @@ -0,0 +1,130 @@ +;; DO NOT: (declare (usual-integrations)) + +;;;; (scode-optimizer cross) + +(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!)))))) + + + diff --git a/v8/src/sf/gconst.scm b/v8/src/sf/gconst.scm new file mode 100644 index 000000000..d3f138342 --- /dev/null +++ b/v8/src/sf/gconst.scm @@ -0,0 +1,290 @@ +#| -*-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)) + +;;; 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! + SUBSTRINGLIST + 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 diff --git a/v8/src/sf/pardec.scm b/v8/src/sf/pardec.scm new file mode 100644 index 000000000..95c4475d8 --- /dev/null +++ b/v8/src/sf/pardec.scm @@ -0,0 +1,490 @@ +#| -*-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")) + +;;;; 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)) + +;;;; 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 + '()) + +;;;; 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)))) + +;;(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)))) + +(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)))))))))) + +;;;; 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)) + '())) + +;;;; 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))) + +(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 diff --git a/v8/src/sf/sf.pkg b/v8/src/sf/sf.pkg new file mode 100644 index 000000000..764d6b325 --- /dev/null +++ b/v8/src/sf/sf.pkg @@ -0,0 +1,183 @@ +#| -*-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 + +(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)) diff --git a/v8/src/sf/subst.scm b/v8/src/sf/subst.scm new file mode 100644 index 000000000..6f6ca74ee --- /dev/null +++ b/v8/src/sf/subst.scm @@ -0,0 +1,1460 @@ +#| -*-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")) + +(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)) + +;;;; 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)))))))) + +(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))))))))) + +(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))))))) + +;;;; 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")))))) + +(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) + +(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))))))) + +(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))) + +(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))))) + +(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))))) + +(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))))) + +;;;; 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)))) + +(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))))) + +(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)) + +(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)) + +;;;; 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))) + +;;; 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)))) + +(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)))))))))) + +(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)) + +(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)))))) + +;;; 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))) + +(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)) + +(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))))) + +(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))))))) + +(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 diff --git a/v8/src/sf/usicon.scm b/v8/src/sf/usicon.scm new file mode 100644 index 000000000..62f087ee5 --- /dev/null +++ b/v8/src/sf/usicon.scm @@ -0,0 +1,91 @@ +#| -*-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")) + +(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 diff --git a/v8/src/sf/usiexp.scm b/v8/src/sf/usiexp.scm new file mode 100644 index 000000000..9eb03882c --- /dev/null +++ b/v8/src/sf/usiexp.scm @@ -0,0 +1,682 @@ +#| -*-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")) + +(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))) + + ;;;; 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)) + + ;;;; 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))) + + ;;;; 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))))) + + #| + (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))))) + |# + + (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))))) + + ;;;; 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))) + + ;;;; 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)) + + ;;;; 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))))) + + (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))) + + (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) + +(define usual-integrations/expansion-alist) + +(define (usual-integrations/initialize-expanders!) + (set! usual-integrations/expansion-alist + (usual-integrations/make-expansion-alist))) + +;;;; 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 -- 2.25.1