#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/chtype.scm,v 4.1 1988/06/13 12:29:10 cph Rel $
+$Id: chtype.scm,v 4.2 1993/01/02 07:33:33 cph Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+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
;;;; SCode Optimizer: Intern object types
(declare (usual-integrations)
- (automagic-integrations)
(integrate-external "object"))
\f
-(define (intern-type block expression)
- (change-type/block block)
- (change-type/expression expression)
- (make-integration-info expression (block/bound-variables block)))
-
(define (change-type/block block)
(change-type/object enumeration/random block)
- (for-each (lambda (variable)
- (change-type/object enumeration/random variable))
- (block/bound-variables block))
+ (block/for-each-bound-variable block
+ (lambda (variable)
+ (change-type/object enumeration/random variable)))
(for-each change-type/block (block/children block)))
(define (change-type/expressions expressions)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/copy.scm,v 4.1 1988/06/13 12:29:14 cph Rel $
+$Id: copy.scm,v 4.2 1993/01/02 07:33:34 cph Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+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
;;;; SCode Optimizer: Copy Expression
(declare (usual-integrations)
- (open-block-optimizations)
- (eta-substitution)
- (automagic-integrations)
(integrate-external "object"))
\f
(define root-block)
+(define copy/variable/free)
+(define copy/declarations)
-(define (copy/expression/intern block expression uninterned)
+(define (copy/expression/intern block expression)
(fluid-let ((root-block block)
(copy/variable/free copy/variable/free/intern)
(copy/declarations copy/declarations/intern))
- (let ((environment
- (environment/rebind block (environment/make) uninterned)))
- (copy/expression root-block
- environment
- expression))))
-
-(define (copy/expression/extern expression)
- (fluid-let ((root-block (block/make false false))
+ (copy/expression block (environment/make) expression)))
+
+(define (copy/expression/extern block expression)
+ (fluid-let ((root-block block)
(copy/variable/free copy/variable/free/extern)
(copy/declarations copy/declarations/extern))
- (let ((environment (environment/make)))
- (let ((expression
- (copy/expression root-block environment expression)))
- (values root-block expression)))))
+ (copy/expression block (environment/make) expression)))
(define (copy/expressions block environment expressions)
(map (lambda (expression)
(copy/expression block environment expression))
expressions))
-(declare (integrate-operator copy/expression))
-
(define (copy/expression block environment expression)
((expression/method dispatch-vector expression)
block environment expression))
(define define-method/copy
(expression/make-method-definer dispatch-vector))
+(define (environment/make)
+ '())
+
+(define (environment/bind environment variables values)
+ (map* environment cons variables values))
+
+(define (environment/lookup environment variable if-found if-not)
+ (let ((association (assq variable environment)))
+ (if association
+ (if-found (cdr association))
+ (if-not))))
+
+(define (environment/rebind block environment variables)
+ (environment/bind
+ environment
+ variables
+ (map (lambda (variable)
+ (block/lookup-name block (variable/name variable) true))
+ variables)))
+
+(define (make-renamer environment)
+ (lambda (variable)
+ (environment/lookup environment variable
+ identity-procedure
+ (lambda () (error "Variable missing during copy operation:" variable)))))
+\f
(define (copy/quotation quotation)
(fluid-let ((root-block false))
(let ((block (quotation/block quotation))
(copy/expression block
environment
(quotation/expression quotation))))))
-\f
+
(define (copy/block parent environment block)
- (let ((result (block/make parent (block/safe? block)))
- (old-bound (block/bound-variables block)))
+ (let ((result (block/make parent (block/safe? block) '()))
+ (old-bound (block/bound-variables-list block)))
(let ((new-bound
(map (lambda (variable)
- (variable/make result
- (variable/name variable)
- (variable/flags variable)))
+ (let ((new
+ (variable/make&bind! result
+ (variable/name variable))))
+ (set-variable/flags! new
+ (list-copy (variable/flags variable)))
+ new))
old-bound)))
(let ((environment (environment/bind environment old-bound new-bound)))
- (set-block/bound-variables! result new-bound)
(set-block/declarations!
result
(copy/declarations block environment (block/declarations block)))
(set-block/flags! result (block/flags block))
(values result environment)))))
-(define copy/variable/free)
-
(define (copy/variable block environment variable)
block ;ignored
(environment/lookup environment variable
identity-procedure
- (copy/variable/free variable)))
+ (lambda () (copy/variable/free variable))))
(define (copy/variable/free/intern variable)
- (lambda ()
- (let ((name (variable/name variable)))
- (let loop ((block root-block))
- (let ((variable* (variable/assoc name (block/bound-variables block))))
- (cond ((eq? variable variable*)
- variable)
- ((not (block/parent block))
- (error "Unable to find free variable during copy" name))
- ((not variable*)
- (loop (block/parent block)))
- ((block/safe? (variable/block variable*))
- (set-variable/name! variable* (rename-symbol name))
- (loop (block/parent block)))
- (else
- (error "Integration requires renaming unsafe variable"
- name))))))))
-
-(define (rename-symbol symbol)
- (string->uninterned-symbol (symbol->string symbol)))
+ (let ((name (variable/name variable)))
+ (let loop ((block root-block))
+ (let ((variable* (block/lookup-name block name false)))
+ (if (not variable*)
+ (error "Unable to find free variable during copy:" name))
+ (if (eq? variable variable*)
+ variable
+ (begin
+ (if (not (block/parent block))
+ (error "Unable to find free variable during copy:" name))
+ (if (not (block/safe? (variable/block variable*)))
+ (error "Integration requires renaming unsafe variable:"
+ name))
+ (set-variable/name!
+ variable*
+ (string->uninterned-symbol (symbol->string name)))
+ (loop (block/parent block))))))))
(define (copy/variable/free/extern variable)
- (lambda ()
- (block/lookup-name root-block (variable/name variable) true)))
-\f
-(define copy/declarations)
+ (block/lookup-name root-block (variable/name variable) true))
(define (copy/declarations/intern block environment declarations)
- block ; ignored
+ block ;ignored
(if (null? declarations)
'()
(declarations/map declarations
(environment/lookup environment variable
identity-procedure
(lambda ()
- (block/lookup-name root-block
- (variable/name variable) true))))
+ (block/lookup-name root-block (variable/name variable) true))))
(lambda (expression)
(copy/expression block environment expression)))))
-
-(define (environment/make)
- '())
-
-(define (environment/bind environment variables values)
- (map* environment cons variables values))
-
-(define (environment/lookup environment variable if-found if-not)
- (let ((association (assq variable environment)))
- (if association
- (if-found (cdr association))
- (if-not))))
-
-(define (environment/rebind block environment variables)
- (environment/bind
- environment
- variables
- (map (lambda (variable)
- (block/lookup-name block (variable/name variable) true))
- variables)))
-
-(define (make-renamer environment)
- (lambda (variable)
- (environment/lookup environment variable
- identity-procedure
- (lambda () (error "Missing variable during copy operation" variable)))))
\f
(define-method/copy 'ACCESS
(lambda (block environment expression)
- (access/make (copy/expression block environment
+ (access/make (copy/expression block
+ environment
(access/environment expression))
(access/name expression))))
(define-method/copy 'COMBINATION
(lambda (block environment expression)
- (let ((operator (combination/operator expression))
- (operands (combination/operands expression)))
- (if (and (operator/error-procedure? operator)
- (the-environment? (caddr operands)))
- (combination/make
- operator
- (list (copy/expression block environment (car operands))
- (copy/expression block environment (cadr operands))
- (the-environment/make block)))
- (combination/make
- (copy/expression block environment operator)
- (copy/expressions block environment operands))))))
-
-(define (operator/error-procedure? operator)
- (or (and (constant? operator)
- (eq? error-procedure (constant/value operator)))
- (and (access? operator)
- (eq? 'ERROR-PROCEDURE (access/name operator))
- (let ((environment (access/environment operator)))
- (and (constant? environment)
- (not (constant/value environment)))))))
+ (combination/make
+ (copy/expression block environment (combination/operator expression))
+ (copy/expressions block environment (combination/operands expression)))))
(define-method/copy 'CONDITIONAL
(lambda (block environment expression)
(conditional/make
(copy/expression block environment (conditional/predicate expression))
(copy/expression block environment (conditional/consequent expression))
- (copy/expression block environment
+ (copy/expression block
+ environment
(conditional/alternative expression)))))
(define-method/copy 'CONSTANT
(lambda (block environment expression)
- block environment ; ignored
+ block environment ;ignored
expression))
(define-method/copy 'DECLARATION
(lambda (block environment expression)
(declaration/make
- (copy/declarations block environment
+ (copy/declarations block
+ environment
(declaration/declarations expression))
(copy/expression block environment (declaration/expression expression)))))
(lambda (block environment expression)
(delay/make
(copy/expression block environment (delay/expression expression)))))
-\f
+
(define-method/copy 'DISJUNCTION
(lambda (block environment expression)
(disjunction/make
(copy/expression block environment (disjunction/predicate expression))
- (copy/expression block environment
+ (copy/expression block
+ environment
(disjunction/alternative expression)))))
(define-method/copy 'IN-PACKAGE
(in-package/make
(copy/expression block environment (in-package/environment expression))
(copy/quotation (in-package/quotation expression)))))
-
+\f
(define-method/copy 'PROCEDURE
(lambda (block environment procedure)
- (with-values
+ (call-with-values
(lambda ()
(copy/block block environment (procedure/block procedure)))
(lambda (block environment)
(map rename (procedure/required procedure))
(map rename (procedure/optional procedure))
(let ((rest (procedure/rest procedure)))
- (and rest (rename rest)))
- (copy/expression block environment
+ (and rest
+ (rename rest)))
+ (copy/expression block
+ environment
(procedure/body procedure))))))))
(define-method/copy 'OPEN-BLOCK
(lambda (block environment expression)
- (with-values
+ (call-with-values
(lambda ()
(copy/block block environment (open-block/block expression)))
(lambda (block environment)
(define-method/copy 'QUOTATION
(lambda (block environment expression)
- block environment ; ignored
+ block environment ;ignored
(copy/quotation expression)))
(define-method/copy 'REFERENCE
(reference/make block
(copy/variable block environment
(reference/variable expression)))))
-\f
+
(define-method/copy 'SEQUENCE
(lambda (block environment expression)
(sequence/make
(define-method/copy 'THE-ENVIRONMENT
(lambda (block environment expression)
- block environment expression ; ignored
+ block environment expression ;ignored
(error "Attempt to integrate expression containing (THE-ENVIRONMENT)")))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/emodel.scm,v 4.1 1988/06/13 12:29:20 cph Rel $
+$Id: emodel.scm,v 4.2 1993/01/02 07:33:35 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+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
(declare (usual-integrations)
(integrate-external "object"))
\f
-(define variable/assoc
- (association-procedure eq? variable/name))
+(define (block/make parent safe? bound-variables)
+ (let ((block
+ (%block/make parent
+ safe?
+ (let ((n-bound-variables (length bound-variables)))
+ (if (fix:<= n-bound-variables block-hash-table-limit)
+ (cons n-bound-variables bound-variables)
+ (make-hash-table bound-variables))))))
+ (if parent
+ (set-block/children! parent (cons block (block/children parent))))
+ block))
-(define (block/unsafe! block)
- (if (block/safe? block)
- (begin (set-block/safe?! block false)
- (if (block/parent block)
- (block/unsafe! (block/parent block))))))
+(define (variable/make&bind! block name)
+ (let ((variable (variable/make block name '()))
+ (bound-variables (block/bound-variables block)))
+ (cond ((hash-table? bound-variables)
+ (hash-table-store! bound-variables variable))
+ ((fix:= (car bound-variables) block-hash-table-limit)
+ (set-block/bound-variables!
+ block
+ (make-hash-table (cons variable (cdr bound-variables)))))
+ (else
+ (set-car! bound-variables (fix:+ (car bound-variables) 1))
+ (set-cdr! bound-variables (cons variable (cdr bound-variables)))))
+ variable))
+
+(define-integrable block-hash-table-limit
+ 20)
(define (block/lookup-name block name intern?)
(let search ((block block))
- (or (variable/assoc name (block/bound-variables block))
- (let ((parent (block/parent block)))
- (cond ((not (null? parent))
- (search parent))
- (intern?
- (variable/make&bind! block name))
- (else #f))))))
+ (let ((bound-variables (block/bound-variables block)))
+ (if (hash-table? bound-variables)
+ (or (hash-table-lookup bound-variables name)
+ (if (block/parent block)
+ (search (block/parent block))
+ (and intern? (variable/make&bind! block name))))
+ (let loop ((variables (cdr bound-variables)))
+ (cond ((null? variables)
+ (if (block/parent block)
+ (search (block/parent block))
+ (and intern? (variable/make&bind! block name))))
+ ((eq? name (variable/name (car variables)))
+ (car variables))
+ (else
+ (loop (cdr variables)))))))))
+
+(define (block/limited-lookup block name limit)
+ (let search ((block block))
+ (and (not (eq? block limit))
+ (let ((bound-variables (block/bound-variables block)))
+ (if (hash-table? bound-variables)
+ (or (hash-table-lookup bound-variables name)
+ (and (block/parent block)
+ (search (block/parent block))))
+ (let loop ((variables (cdr bound-variables)))
+ (cond ((null? variables)
+ (and (block/parent block)
+ (search (block/parent block))))
+ ((eq? name (variable/name (car variables)))
+ (car variables))
+ (else
+ (loop (cdr variables))))))))))
+\f
+(define-structure (hash-table
+ (type vector)
+ (named (string->symbol "#[(scode-optimizer)hash-table]"))
+ (constructor %make-hash-table))
+ count
+ buckets)
+
+(define (make-hash-table variables)
+ (let ((count (length variables)))
+ (let ((buckets (make-hash-table-buckets (fix:+ count 1))))
+ (let ((table (%make-hash-table count buckets)))
+ (for-each (lambda (variable)
+ (%hash-table-store! buckets variable))
+ variables)
+ table))))
+
+(define (hash-table-store! table variable)
+ (let ((count (fix:+ (hash-table-count table) 1)))
+ (if (fix:= count (vector-length (hash-table-buckets table)))
+ (let ((old-buckets (hash-table-buckets table)))
+ (let ((new-buckets (make-hash-table-buckets (fix:+ count count))))
+ (do ((h 0 (fix:+ h 1)))
+ ((fix:= h count))
+ (let ((variable (vector-ref old-buckets h)))
+ (if variable
+ (%hash-table-store! new-buckets variable))))
+ (set-hash-table-buckets! table new-buckets))))
+ (set-hash-table-count! table count))
+ (%hash-table-store! (hash-table-buckets table) variable))
+(define (%hash-table-store! buckets variable)
+ (let ((k (symbol-hash (variable/name variable)))
+ (m (vector-length buckets)))
+ (let ((h1 (modulo k m)))
+ (if (not (vector-ref buckets h1))
+ (vector-set! buckets h1 variable)
+ (let ((h2 (fix:+ (modulo k (fix:- m 1)) 1)))
+ (let loop ((h h1))
+ (let ((h
+ (let ((h (fix:+ h h2)))
+ (if (fix:< h m)
+ h
+ (fix:- h m)))))
+ (if (not (vector-ref buckets h))
+ (vector-set! buckets h variable)
+ (loop h)))))))))
+
+(define (make-hash-table-buckets n)
+ (make-vector (let loop ((primes prime-numbers-stream))
+ (if (<= n (car primes))
+ (car primes)
+ (loop (force (cdr primes)))))
+ false))
+
+(define (hash-table-lookup table name)
+ (let ((buckets (hash-table-buckets table)))
+ (let ((k (symbol-hash name))
+ (m (vector-length buckets)))
+ (let ((h1 (modulo k m)))
+ (let ((variable (vector-ref buckets h1)))
+ (and variable
+ (if (eq? name (variable/name variable))
+ variable
+ (let ((h2 (fix:+ (modulo k (fix:- m 1)) 1)))
+ (let loop ((h h1))
+ (let ((h
+ (let ((h (fix:+ h h2)))
+ (if (fix:< h m)
+ h
+ (fix:- h m)))))
+ (let ((variable (vector-ref buckets h)))
+ (and variable
+ (if (eq? name (variable/name variable))
+ variable
+ (loop h))))))))))))))
+\f
(define (block/lookup-names block names intern?)
(map (lambda (name)
(block/lookup-name block name intern?))
- names))
\ No newline at end of file
+ names))
+
+(define (block/for-each-bound-variable block procedure)
+ (let ((bound-variables (block/bound-variables block)))
+ (if (hash-table? bound-variables)
+ (let ((buckets (hash-table-buckets bound-variables)))
+ (let ((m (vector-length buckets)))
+ (do ((h 0 (fix:+ h 1)))
+ ((fix:= h m))
+ (if (vector-ref buckets h)
+ (procedure (vector-ref buckets h))))))
+ (for-each procedure (cdr bound-variables)))))
+
+(define (block/bound-variables-list block)
+ (let ((bound-variables (block/bound-variables block)))
+ (if (hash-table? bound-variables)
+ (let ((buckets (hash-table-buckets bound-variables)))
+ (let ((m (vector-length buckets)))
+ (let loop ((h 0) (result '()))
+ (if (fix:= h m)
+ result
+ (loop (fix:+ h 1)
+ (if (vector-ref buckets h)
+ (cons (vector-ref buckets h) result)
+ result))))))
+ (cdr bound-variables))))
+
+(define (block/unsafe! block)
+ (if (block/safe? block)
+ (begin
+ (set-block/safe?! block false)
+ (if (block/parent block)
+ (block/unsafe! (block/parent block))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/free.scm,v 4.1 1988/06/13 12:31:26 cph Rel $
+$Id: free.scm,v 4.2 1993/01/02 07:33:35 cph Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+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
;;;; SCode Optimizer: Free Variable Analysis
(declare (usual-integrations)
- (automagic-integrations)
- (open-block-optimizations)
- (eta-substitution)
(integrate-external "object" "lsets"))
\f
(declare (integrate-operator no-free-variables singleton-variable
(define-method/free 'PROCEDURE
(lambda (expression)
- (set/difference (free/expression (procedure/body expression))
- (list->variable-set
- (block/bound-variables (procedure/block expression))))))
+ (set/difference
+ (free/expression (procedure/body expression))
+ (list->variable-set
+ (block/bound-variables-list (procedure/block expression))))))
(define-method/free 'OPEN-BLOCK
(lambda (expression)
(set/union (free/expression (car actions))
(loop (cdr actions)))))))
(list->variable-set
- (block/bound-variables (open-block/block expression))))))
+ (block/bound-variables-list (open-block/block expression))))))
(define-method/free 'QUOTATION
(lambda (expression)
(define-method/free 'THE-ENVIRONMENT
(lambda (expression)
expression
- (no-free-variables)))
+ (no-free-variables)))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: make.scm,v 4.25 1992/12/02 19:36:41 cph Exp $
+$Id: make.scm,v 4.26 1993/01/02 07:33:35 cph Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+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
(package/system-loader "sf" '() 'QUERY)
((package/reference (find-package '(SCODE-OPTIMIZER))
'USUAL-INTEGRATIONS/CACHE!))
-(add-system! (make-system "SF" 4 25 '()))
\ No newline at end of file
+(add-system! (make-system "SF" 4 26 '()))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: object.scm,v 4.4 1992/12/03 03:18:21 cph Exp $
+$Id: object.scm,v 4.5 1993/01/02 07:33:36 cph Exp $
-Copyright (c) 1987-1992 Massachusetts Institute of Technology
+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
;;;; SCode Optimizer: Data Types
;;; package: (scode-optimizer)
-(declare (usual-integrations)
- (automagic-integrations)
- (open-block-optimizations))
-\f
-(let-syntax
- ((define-enumerand
- (macro (name enumeration)
- `(DEFINE ,(symbol-append name '/ENUMERAND)
- (ENUMERATION/NAME->ENUMERAND
- ,(symbol-append 'ENUMERATION/ enumeration)
- ',name))))
- (define-simple-type
- (macro (name enumeration slots)
- `(BEGIN
- (DEFINE-ENUMERAND ,name ,enumeration)
- (DEFINE-STRUCTURE (,name
- (TYPE VECTOR)
- (NAMED ,(symbol-append name '/ENUMERAND))
- (CONC-NAME ,(symbol-append name '/))
- (CONSTRUCTOR ,(symbol-append name '/MAKE)))
- ,@slots)))))
-
-(define-integrable (object/enumerand object)
- (vector-ref object 0))
-
-(define-integrable (set-object/enumerand! object enumerand)
- (vector-set! object 0 enumerand))
+(declare (usual-integrations))
\f
;;;; Enumerations
(define (enumeration/name->enumerand enumeration name)
(cdr (or (assq name (cdr enumeration))
- (error "Unknown enumeration name" name))))
+ (error "Unknown enumeration name:" name))))
(define (enumeration/name->index enumeration name)
(enumerand/index (enumeration/name->enumerand enumeration name)))
-\f
-;;;; Random Types
-(define enumeration/random
- (enumeration/make
- '(BLOCK
- DELAYED-INTEGRATION
- VARIABLE
- )))
+(let-syntax
+ ((define-enumeration
+ (macro (enumeration-name enumerand-names)
+ `(BEGIN
+ (DEFINE ,enumeration-name
+ (ENUMERATION/MAKE ',enumerand-names))
+ ,@(map (lambda (enumerand-name)
+ `(DEFINE ,(symbol-append enumerand-name '/ENUMERAND)
+ (ENUMERATION/NAME->ENUMERAND ,enumeration-name
+ ',enumerand-name)))
+ enumerand-names)))))
+ (define-enumeration enumeration/random
+ (block
+ delayed-integration
+ variable))
+ (define-enumeration enumeration/expression
+ (access
+ assignment
+ combination
+ conditional
+ constant
+ declaration
+ delay
+ disjunction
+ in-package
+ open-block
+ procedure
+ quotation
+ reference
+ sequence
+ the-environment)))
+\f
+;;;; Records
-(define-enumerand block random)
(define-structure (block (type vector)
(named block/enumerand)
(conc-name block/)
- (constructor %block/make))
+ (constructor %block/make
+ (parent safe? bound-variables)))
parent
- children
+ (children '())
safe?
- declarations
+ (declarations (declarations/make-null))
bound-variables
- flags)
+ (flags '()))
-(define (block/make parent safe?)
- (let ((block
- (%block/make parent '() safe? (declarations/make-null) '() '())))
- (if parent
- (set-block/children! parent (cons block (block/children parent))))
- block))
-
-(define-enumerand delayed-integration random)
(define-structure (delayed-integration
(type vector)
(named delayed-integration/enumerand)
operations
value)
-(define-simple-type variable random
- (block name flags))
-
-(define (variable/make&bind! block name)
- (let ((variable (variable/make block name '())))
- (set-block/bound-variables! block
- (cons variable
- (block/bound-variables block)))
- variable))
-
-(define-integrable (variable/flag? variable flag)
- (memq flag (variable/flags variable)))
+(let-syntax
+ ((define-simple-type
+ (macro (name slots)
+ `(DEFINE-STRUCTURE (,name (TYPE VECTOR)
+ (NAMED ,(symbol-append name '/ENUMERAND))
+ (CONC-NAME ,(symbol-append name '/))
+ (CONSTRUCTOR ,(symbol-append name '/MAKE)))
+ ,@slots))))
+ (define-simple-type variable (block name flags))
+ (define-simple-type access (environment name))
+ (define-simple-type assignment (block variable value))
+ (define-simple-type combination (operator operands))
+ (define-simple-type conditional (predicate consequent alternative))
+ (define-simple-type constant (value))
+ (define-simple-type declaration (declarations expression))
+ (define-simple-type delay (expression))
+ (define-simple-type disjunction (predicate alternative))
+ (define-simple-type in-package (environment quotation))
+ (define-simple-type open-block (block variables values actions optimized))
+ (define-simple-type procedure (block name required optional rest body))
+ (define-simple-type quotation (block expression))
+ (define-simple-type reference (block variable))
+ (define-simple-type sequence (actions))
+ (define-simple-type the-environment (block)))
-(define (set-variable/flag! variable flag)
- (if (not (variable/flag? variable flag))
- (set-variable/flags! variable
- (cons flag (variable/flags variable)))))
+(define-integrable (object/enumerand object)
+ (vector-ref object 0))
-(let-syntax ((define-flag
- (macro (name tester setter)
- `(BEGIN
- (DEFINE (,tester VARIABLE)
- (VARIABLE/FLAG? VARIABLE (QUOTE ,name)))
- (DEFINE (,setter VARIABLE)
- (SET-VARIABLE/FLAG! VARIABLE (QUOTE ,name)))))))
+(define-integrable (set-object/enumerand! object enumerand)
+ (vector-set! object 0 enumerand))
+\f
+;;;; Miscellany
+(let-syntax
+ ((define-flag
+ (macro (name tester setter)
+ `(BEGIN
+ (DEFINE (,tester VARIABLE)
+ (MEMQ ',name (VARIABLE/FLAGS VARIABLE)))
+ (DEFINE (,setter VARIABLE)
+ (IF (NOT (MEMQ ',name (VARIABLE/FLAGS VARIABLE)))
+ (SET-VARIABLE/FLAGS! VARIABLE
+ (CONS ',name
+ (VARIABLE/FLAGS VARIABLE)))))))))
(define-flag SIDE-EFFECTED variable/side-effected variable/side-effect!)
(define-flag REFERENCED variable/referenced variable/reference!)
(define-flag INTEGRATED variable/integrated variable/integrated!)
- (define-flag CAN-IGNORE variable/can-ignore? variable/can-ignore!)
- )
+ (define-flag CAN-IGNORE variable/can-ignore? variable/can-ignore!))
(define open-block/value-marker
;; This must be an interned object because we will fasdump it and
;; fasload it back in.
(intern "#[(scode-optimizer)open-block/value-marker]"))
-\f
-;;;; Expression Types
-
-(define enumeration/expression
- (enumeration/make
- '(ACCESS
- ASSIGNMENT
- COMBINATION
- CONDITIONAL
- CONSTANT
- DECLARATION
- DELAY
- DISJUNCTION
- IN-PACKAGE
- OPEN-BLOCK
- PROCEDURE
- QUOTATION
- REFERENCE
- SEQUENCE
- THE-ENVIRONMENT
- )))
(define (expression/make-dispatch-vector)
(make-vector (enumeration/cardinality enumeration/expression)))
;; Useful for debugging
(vector-ref dispatch-vector
(enumeration/name->index enumeration/expression name)))
-\f
-(define-simple-type access expression (environment name))
-(define-simple-type assignment expression (block variable value))
-(define-simple-type combination expression (operator operands))
-(define-simple-type conditional expression (predicate consequent alternative))
-(define-simple-type constant expression (value))
-(define-simple-type declaration expression (declarations expression))
-(define-simple-type delay expression (expression))
-(define-simple-type disjunction expression (predicate alternative))
-(define-simple-type in-package expression (environment quotation))
-(define-simple-type open-block expression (block variables values actions
- optimized))
-(define-simple-type procedure expression
- (block name required optional rest body))
-(define-simple-type quotation expression (block expression))
-(define-simple-type reference expression (block variable))
-(define-simple-type sequence expression (actions))
-(define-simple-type the-environment expression (block))
-
-;;; end LET-SYNTAX
-)
(define-integrable (global-ref/make name)
- ;; system-global-environment = ()
- (access/make (constant/make '()) name))
+ (access/make (constant/make system-global-environment) name))
-(define (global-ref? obj)
- (and (access? obj)
- (constant? (access/environment obj))
- (eq? (constant/value (access/environment obj)) '())
- (access/name obj)))
+(define (global-ref? object)
+ (and (access? object)
+ (constant? (access/environment object))
+ (eq? system-global-environment
+ (constant/value (access/environment object)))
+ (access/name object)))
(define-integrable (constant->integration-info constant)
- (make-integration-info (constant/make constant) '()))
+ (make-integration-info (constant/make constant)))
-(define-integrable (integration-info? obj)
- (pair? obj))
+(define-integrable (integration-info? object)
+ (and (pair? object)
+ (eq? integration-info-tag (car object))))
-(define-integrable (make-integration-info expression uninterned-variables)
- (cons expression uninterned-variables))
+(define-integrable (make-integration-info expression)
+ (cons integration-info-tag expression))
(define-integrable (integration-info/expression integration-info)
- (car integration-info))
+ (cdr integration-info))
-(define-integrable (integration-info/uninterned-variables integration-info)
- (cdr integration-info))
\ No newline at end of file
+(define integration-info-tag
+ (string-copy "integration-info"))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: pardec.scm,v 4.6 1992/11/04 10:17:33 jinx Exp $
+$Id: pardec.scm,v 4.7 1993/01/02 07:33:36 cph Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+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
;;; package: (scode-optimizer declarations)
(declare (usual-integrations)
- (open-block-optimizations)
- (automagic-integrations)
- (eta-substitution)
(integrate-external "object"))
\f
-(define (declarations/make-null)
- (declarations/make '() '() '()))
+;;;; Main Entry Points
(define (declarations/parse block declarations)
- (let ((bindings
- (accumulate
- (lambda (bindings declaration)
- (parse-declaration block bindings/cons bindings declaration))
- (cons '() '())
- declarations)))
- (declarations/make declarations (car bindings) (cdr bindings))))
-
-(define (parse-declaration block table/conser bindings declaration)
+ (make-declaration-set declarations
+ (append-map (lambda (declaration)
+ (parse-declaration block declaration))
+ declarations)))
+
+(define (declarations/make-null)
+ (make-declaration-set '() '()))
+
+(define (declarations/original declaration-set)
+ (declaration-set/original declaration-set))
+
+(define (declarations/bind operations declaration-set)
+ (let loop
+ ((operations operations)
+ (declarations (declaration-set/declarations declaration-set)))
+ (if (null? declarations)
+ operations
+ (loop (let ((declaration (car declarations)))
+ ((if (declaration/overridable? declaration)
+ operations/bind-global
+ operations/bind)
+ operations
+ (declaration/operation declaration)
+ (declaration/variable declaration)
+ (declaration/value declaration)))
+ (cdr declarations)))))
+
+(define (declarations/map declaration-set per-variable per-value)
+ (make-declaration-set
+ (declaration-set/original declaration-set)
+ (map (lambda (declaration)
+ (make-declaration (declaration/operation declaration)
+ (per-variable (declaration/variable declaration))
+ (let ((value (declaration/value declaration)))
+ (and value
+ (per-value value)))
+ (declaration/overridable? declaration)))
+ (declaration-set/declarations declaration-set))))
+
+(define (declarations/known? declaration)
+ (assq (car declaration) known-declarations))
+\f
+;;;; Data Structures
+
+(define-structure (declaration-set
+ (type vector)
+ (named
+ (string->symbol
+ "#[(scode-optimizer declarations)declaration-set]"))
+ (constructor make-declaration-set)
+ (conc-name declaration-set/))
+ (original false read-only true)
+ (declarations false read-only true))
+
+(define-structure (declaration
+ (type vector)
+ (named
+ (string->symbol
+ "#[(scode-optimizer declarations)declaration]"))
+ (constructor make-declaration)
+ (conc-name declaration/))
+ ;; OPERATION is the name of the operation that is to be performed by
+ ;; this declaration.
+ (operation false read-only true)
+
+ ;; The variable that this declaration affects.
+ (variable false read-only true)
+
+ ;; The value associated with this declaration. The meaning of this
+ ;; field depends on OPERATION.
+ (value false read-only true)
+
+ ;; OVERRIDABLE? means that a user-defined variable of the same name
+ ;; will override this declaration. It also means that this
+ ;; declaration should not be written out to the ".ext" file.
+ (overridable? false read-only true))
+
+(define (make-declarations operation variables values overridable?)
+ (if (eq? values 'NO-VALUES)
+ (map (lambda (variable)
+ (make-declaration operation variable false overridable?))
+ variables)
+ (map (lambda (variable value)
+ (make-declaration operation variable value overridable?))
+ variables
+ values)))
+
+(define (parse-declaration block declaration)
(let ((association (assq (car declaration) known-declarations)))
(if (not association)
- bindings
- (let ((before-bindings? (car (cdr association)))
- (parser (cdr (cdr association))))
- (let ((block
- (if before-bindings?
- (let ((block (block/parent block)))
- (if (block/parent block)
- (warn "Declaration not at top level"
- declaration))
- block)
- block)))
- (parser block
- (table/conser block before-bindings?)
- bindings
- (cdr declaration)))))))
-
-(define (bindings/cons block before-bindings?)
- (lambda (bindings global? operation export? names values)
- (let ((result
- (binding/make global? operation export?
- (if global?
- names
- (block/lookup-names block names true))
- values)))
- (if before-bindings?
- (cons (cons result (car bindings)) (cdr bindings))
- (cons (car bindings) (cons result (cdr bindings)))))))
-
-(define-integrable (bind/general table/cons table global? operation export?
- names values)
- (table/cons table global? operation export? names values))
-
-(define-integrable (bind/values table/cons table operation export? names
- values)
- (table/cons table (not export?) operation export? names values))
-
-(define-integrable (bind/no-values table/cons table operation export? names)
- (table/cons table false operation export? names 'NO-VALUES))
-\f
-;; before-bindings? should be true if binding <name> should nullify
-;; the declaration. It should be false if a binding and the
-;; declaration can "coexist".
+ '()
+ ((cdr association) block (cdr declaration)))))
-(define (define-declaration name before-bindings? parser)
- (let ((entry (assq name known-declarations)))
+(define (define-declaration operation parser)
+ (let ((entry (assq operation known-declarations)))
(if entry
- (set-cdr! entry (cons before-bindings? parser))
+ (set-cdr! entry parser)
(set! known-declarations
- (cons (cons name (cons before-bindings? parser))
- known-declarations)))))
-
-(define-integrable (declarations/known? declaration)
- (assq (car declaration) known-declarations))
+ (cons (cons operation parser)
+ known-declarations))))
+ operation)
(define known-declarations
'())
-
-(define (accumulate cons table items)
- (let loop ((table table) (items items))
- (if (null? items)
- table
- (loop (cons table (car items)) (cdr items)))))
\f
-(define (declarations/binders declarations)
- (let ((procedure
- (lambda (bindings)
- (lambda (operations)
- (accumulate (lambda (operations binding)
- ((if (binding/global? binding)
- operations/bind-global
- operations/bind)
- operations
- (binding/operation binding)
- (binding/export? binding)
- (binding/names binding)
- (binding/values binding)))
- operations
- bindings)))))
- (values (procedure (declarations/before declarations))
- (procedure (declarations/after declarations)))))
-
-(define (declarations/for-each-variable declarations procedure)
- (declarations/for-each-binding declarations
- (lambda (binding)
- (if (not (binding/global? binding))
- (for-each procedure (binding/names binding))))))
-
-(define (declarations/for-each-binding declarations procedure)
- (for-each procedure (declarations/before declarations))
- (for-each procedure (declarations/after declarations)))
-
-(define (declarations/map declarations per-name per-value)
- (declarations/map-binding declarations
- (lambda (binding)
- (let ((global? (binding/global? binding))
- (names (binding/names binding))
- (values (binding/values binding)))
- (binding/make global?
- (binding/operation binding)
- (binding/export? binding)
- (if global? names (map per-name names))
- (if (eq? values 'NO-VALUES)
- 'NO-VALUES
- (map per-value values)))))))
-
-(define (declarations/map-binding declarations procedure)
- (declarations/make (declarations/original declarations)
- (map procedure (declarations/before declarations))
- (map procedure (declarations/after declarations))))
-
-(define (declarations/integrated-variables declarations)
- (append-map (lambda (binding)
- (if (and (eq? 'INTEGRATE (binding/operation binding))
- (eq? 'NO-VALUES (binding/values binding)))
- (binding/names binding)
- '()))
- (declarations/after declarations)))
-
-(define-structure (declarations
- (type vector)
- (constructor declarations/make)
- (conc-name declarations/))
- (original false read-only true)
- (before false read-only true)
- (after false read-only true))
-
-(define-structure (binding
- (type vector)
- (constructor binding/make)
- (conc-name binding/))
- (global? false read-only true)
- (operation false read-only true)
- (export? false read-only true)
- (names false read-only true)
- (values false read-only true))
+;;;; 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 (names vals)
+ (if (null? deletions)
+ (values names vals)
+ (let deletion-loop
+ ((names names)
+ (vals vals)
+ (names* '())
+ (vals* '()))
+ (cond ((null? names)
+ (values names* vals*))
+ ((memq (car names) deletions)
+ (deletion-loop (cdr names)
+ (cdr vals)
+ names*
+ vals*))
+ (else
+ (deletion-loop (cdr names)
+ (cdr vals)
+ (cons (car names) names*)
+ (cons (car vals) vals*))))))))
+ (constructor
+ (lambda (operation)
+ (lambda (name value)
+ (let ((variable (block/lookup-name block name false)))
+ (if variable
+ (set! declarations
+ (cons (make-declaration operation
+ variable
+ value
+ true)
+ declarations))
+ (set! remaining
+ (cons (vector operation name value)
+ remaining))))
+ unspecific))))
+ (call-with-values
+ (lambda ()
+ (do-deletions usual-integrations/expansion-names
+ usual-integrations/expansion-values))
+ (lambda (expansion-names expansion-values)
+ (for-each (constructor 'EXPAND)
+ expansion-names
+ expansion-values)))
+ (call-with-values
+ (lambda ()
+ (do-deletions usual-integrations/constant-names
+ usual-integrations/constant-values))
+ (lambda (constant-names constant-values)
+ (for-each (constructor 'INTEGRATE)
+ constant-names
+ constant-values))))
+ (map* declarations
+ (let ((top-level-block
+ (let loop ((block block))
+ (if (block/parent block)
+ (loop (block/parent block))
+ block))))
+ (lambda (remaining)
+ (make-declaration
+ (vector-ref remaining 0)
+ (variable/make&bind! top-level-block (vector-ref remaining 1))
+ (vector-ref remaining 2)
+ true)))
+ remaining))))
\f
-;;;; Integration of System Constants
+(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
+ (block/lookup-name block name true)
+ (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-declaration 'USUAL-INTEGRATIONS true
- (lambda (block table/cons table deletions)
- block ;ignored
- (let* ((deletions (append sf/usual-integrations-default-deletions
- deletions))
- (finish
- (lambda (table operation names vals)
- (with-values
- (lambda ()
- (if (null? deletions)
- (values names vals)
- (let deletion-loop ((names names) (vals vals))
- (cond ((null? names) (values '() '()))
- ((memq (car names) deletions)
- (deletion-loop (cdr names) (cdr vals)))
- (else
- (with-values
- (lambda ()
- (deletion-loop (cdr names) (cdr vals)))
- (lambda (names* vals*)
- (values (cons (car names) names*)
- (cons (car vals) vals*)))))))))
- (lambda (names vals)
- (bind/values table/cons table operation false names vals))))))
- (finish (finish table 'INTEGRATE
- usual-integrations/constant-names
- usual-integrations/constant-values)
- 'EXPAND
- usual-integrations/expansion-names
- usual-integrations/expansion-values))))
-\f
-#|
-The following are allowed:
-
-symbol ; obvious.
-(symbol) ; obvious.
-(symbol1 symbol2) ; use symbol1 for primitive named symbol2.
-(symbol number) ; primitive symbol has arity number.
-(symbol1 symbol2 number) ; use symbol1 for primitive named symbol2
- ; with arity number.
-
-|#
-
-(define (parse-primitive-specification block specification)
- block ;ignored
- (let ((fail
- (lambda ()
- (error "Bad primitive specification" specification)))
- (finish
- (lambda (variable-name arguments)
- (values variable-name
- (constant->integration-info
- (apply make-primitive-procedure arguments))))))
- (cond ((symbol? specification)
- (finish specification (list specification)))
- ((or (not (pair? specification))
- (not (symbol? (car specification))))
- (fail))
- ((null? (cdr specification))
- (finish (car specification) specification))
- ((not (null? (cddr specification)))
- (if (and (null? (cdddr specification))
- (symbol? (cadr specification))
- (number? (caddr specification)))
- (finish (car specification) (cdr specification))
- (fail)))
- ((symbol? (cadr specification))
- (finish (car specification) (cdr specification)))
- ((number? (cadr specification))
- (finish (car specification) specification))
- (else
- (fail)))))
+(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
+ (variable/name variable)
+ (dumpable-expander->dumped-expander value)))
+ (else
+ (error "Unrecognized extern value:" value))))))))))
\f
-;;; Special declarations courtesy JRM
-;;; I return the operations table unmodified, but bash on the
-;;; block. This actually works pretty well.
+;;;; Flag Declarations
(for-each (lambda (flag)
- (define-declaration flag false
- (lambda (block table/cons table names)
- table/cons names ;ignore
- (set-block/flags! block (cons flag (block/flags block)))
- table)))
+ (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))
-\f
-;;;; Integration of User Code
-
-(define-declaration 'INTEGRATE false
- (lambda (block table/cons table names)
- block ;ignored
- (bind/no-values table/cons table 'INTEGRATE true names)))
-(define-declaration 'INTEGRATE-OPERATOR false
- (lambda (block table/cons table names)
- block ;ignored
- (bind/no-values table/cons table 'INTEGRATE-OPERATOR true names)))
-
-(define-declaration 'INTEGRATE-EXTERNAL true
- (lambda (block table/cons table specifications)
- (accumulate
- (lambda (table extern)
- (let ((operation (vector-ref extern 1))
- (vref2 (vector-ref extern 2))
- (vref3 (vector-ref extern 3)))
- (if (and (eq? operation 'EXPAND)
- (eq? vref2 '*DUMPED-EXPANDER*))
- (parse-declaration
- block
- (lambda (block before-bindings?)
- block ; ignored
- (if before-bindings?
- (warn "INTEGRATE-EXTERNAL: before-bindings expander"
- (car vref3)))
- table/cons)
- table
- vref3)
- (bind/general table/cons table true
- operation false
- (list (vector-ref extern 0))
- (list (intern-type vref2 vref3))))))
- table
- (append-map! read-externs-file
- (append-map! specification->pathnames specifications)))))
-
-(define-declaration 'INTEGRATE-SAFELY false
- (lambda (block table/cons table names)
- block ;ignored
- (bind/no-values table/cons table 'INTEGRATE-SAFELY true names)))
-
-(define-declaration 'IGNORE false
- (lambda (block table/cons table names)
- (declare (ignore table/cons))
- (for-each (lambda (var)
- (and var
- (variable/can-ignore! var)))
+(define-declaration 'IGNORE
+ (lambda (block names)
+ (for-each (lambda (variable)
+ (if variable
+ (variable/can-ignore! variable)))
(block/lookup-names block names false))
- table))
-
-(define (specification->pathnames specification)
- (let ((value
- (scode-eval (syntax specification system-global-syntax-table)
- syntaxer/default-environment)))
- (if (pair? value)
- (map ->pathname value)
- (list (->pathname value)))))
-
-(define (operations->external operations environment)
- (operations/extract-external operations
- (lambda (variable operation info if-ok if-not)
- (let ((finish
- (lambda (value)
- (if-ok
- (with-values (lambda () (copy/expression/extern value))
- (lambda (block expression)
- (vector (variable/name variable)
- operation
- block
- expression))))))
- (fail
- (lambda ()
- (error "operations->external: Unrecognized processor" info))))
-
- (cond ((not info)
- (variable/final-value variable environment finish if-not))
- ((integration-info? info)
- (finish (integration-info/expression info)))
- ((entity? info)
- (let ((xtra (entity-extra info)))
- (if (or (not (pair? xtra))
- (not (eq? '*DUMPABLE-EXPANDER* (car xtra))))
- (fail))
- (if-ok
- (vector (variable/name variable)
- operation
- '*DUMPED-EXPANDER*
- (cdr xtra)))))
- (else
- (fail)))))))
+ '()))
\f
-;;;; User provided reductions and expansions.
-;; See reduct.scm for description of REDUCE-OPERATOR and REPLACE-OPERATOR.
+;;;; Reductions and Expansions
+;;; See "reduct.scm" for description of REDUCE-OPERATOR and REPLACE-OPERATOR.
-(define-declaration 'REDUCE-OPERATOR false
- (lambda (block table/cons table reduction-rules)
- block ;ignored
+(define-declaration 'REDUCE-OPERATOR
+ (lambda (block reduction-rules)
(check-declaration-syntax 'REDUCE-OPERATOR reduction-rules)
- (bind/general table/cons table false 'EXPAND true
- (map car reduction-rules)
- (map (lambda (rule)
- (dumpable-expander
- 'REDUCE-OPERATOR
- rule
- (reducer/make rule block)))
- reduction-rules))))
-
-(define-declaration 'REPLACE-OPERATOR false
- (lambda (block table/cons table replacements)
- block
+ (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-declaration 'REPLACE-OPERATOR
+ (lambda (block replacements)
(check-declaration-syntax 'REPLACE-OPERATOR replacements)
- (bind/general table/cons table false 'EXPAND true
- (map car replacements)
- (map (lambda (replacement)
- (dumpable-expander
- 'REPLACE-OPERATOR
- replacement
- (replacement/make replacement block)))
- replacements))))
-
-(define (dumpable-expander declaration text expander)
+ (map (lambda (replacement)
+ (make-declaration 'EXPAND
+ (block/lookup-name block (car replacement) true)
+ (make-dumpable-expander
+ (replacement/make replacement block)
+ `(REPLACE-OPERATOR ,replacement))
+ false))
+ replacements)))
+
+(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 (make-dumpable-expander expander declaration)
(make-entity (lambda (self operands if-expanded if-not-expanded block)
self ; ignored
(expander operands if-expanded if-not-expanded block))
- (cons '*DUMPABLE-EXPANDER*
- (list declaration text))))
-
-(define (check-declaration-syntax kind decls)
- (if (or (not (list? decls))
- (there-exists? decls
- (lambda (decl)
- (or (not (pair? decl))
- (not (list? (cdr decl)))
- (not (symbol? (car decl)))))))
- (error "Bad declaration" kind decls)))
+ (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 true
- (lambda (block table/cons table expanders)
+(define-declaration 'EXPAND-OPERATOR
+ (lambda (block expanders)
block ;ignored
- (bind/general table/cons table false 'EXPAND false
- (map car expanders)
- (map (lambda (expander)
- (eval (cadr expander)
- expander-evaluation-environment))
- expanders))))
\ No newline at end of file
+ (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
#| -*-Scheme-*-
-$Id: reduct.scm,v 4.3 1992/11/04 10:17:34 jinx Exp $
+$Id: reduct.scm,v 4.4 1993/01/02 07:33:36 cph Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+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
(replace-operator (<name> (<nargs1> <value1>) (<nargs2> <value2>) ...))
<name> is a symbol
-<nargs1> is a non-negative integer or one of the symbols ANY, ELSE, and OTHERWISE.
+<nargs1> is a non-negative integer or one of the symbols ANY, ELSE, OTHERWISE.
<valueN> is a simple expression:
<symbol> ; means a variable
(QUOTE <constant>) = '<constant> ; means a constant
(define (any-shadowed? var-list source target)
(let loop ((l var-list))
(and (not (null? l))
- (or (shadowed? (variable/name (car l)) source target)
+ (or (block/limited-lookup target (variable/name (car l)) source)
(loop (cdr l))))))
-(define (shadowed? name source target)
- (let search ((block target))
- (and (not (eq? block source))
- (or (variable/assoc name (block/bound-variables block))
- (let ((parent (block/parent block)))
- (and (not (null? parent))
- (search parent)))))))
-
(define (filter-vars expr-list)
(let loop ((l expr-list)
(done '()))
;;;; Replacement top level
(define (replacement/make replacement decl-block)
- (with-values
+ (call-with-values
(lambda ()
(parse-replacement (car replacement)
(cdr replacement)
default)))
(if (or (not (pair? candidate))
(and (car candidate)
- (shadowed? (car candidate) decl-block block)))
+ (block/limited-lookup block
+ (car candidate)
+ decl-block)))
(if-not-expanded)
(if-expanded
(combination/make (let ((frob (cdr candidate)))
#| -*-Scheme-*-
-$Id: sf.pkg,v 4.7 1992/11/04 10:17:36 jinx Exp $
+$Id: sf.pkg,v 4.8 1993/01/02 07:33:37 cph Exp $
Copyright (c) 1987-1992 Massachusetts Institute of Technology
(parent (scode-optimizer))
(export ()
sf
- sf:noisy?
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/set-usual-integrations-default-deletions!
- sfu?
- syntax&integrate
- )
+ sf:noisy?
+ syntax&integrate)
(export (scode-optimizer)
integrate/procedure
integrate/file
(files "pardec")
(parent (scode-optimizer))
(export (scode-optimizer)
+ declarations/bind
declarations/known?
declarations/make-null
- declarations/parse
- declarations/binders
- declarations/original
declarations/map
- declarations/for-each-variable
- declarations/integrated-variables
+ declarations/original
+ declarations/parse
operations->external))
(define-package (scode-optimizer copy)
(files "chtype")
(parent (scode-optimizer))
(export (scode-optimizer)
- intern-type))
+ change-type/block
+ change-type/expression))
(define-package (scode-optimizer build-utilities)
(files "butils")
#| -*-Scheme-*-
-$Id: subst.scm,v 4.8 1992/11/06 15:49:11 jinx Exp $
+$Id: subst.scm,v 4.9 1993/01/02 07:33:37 cph Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+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
;;; package: (scode-optimizer integrate)
(declare (usual-integrations)
- (eta-substitution)
- (open-block-optimizations)
(integrate-external "object" "lsets"))
\f
(define *top-level-block*)
(define (integrate/top-level block expression)
(fluid-let ((*top-level-block* block)
(*current-block-names* '()))
- (process-block-flags (block/flags block)
- (lambda ()
- (let ((operations (operations/bind-block (operations/make) block))
- (environment (environment/make)))
- (if (open-block? expression)
- (with-values
- (lambda ()
- (environment/recursive-bind
- operations environment
- (open-block/variables expression)
- (open-block/values expression)))
- (lambda (environment vals)
- (values operations
- environment
- (quotation/make block
- (integrate/open-block operations
- environment
- expression
- vals)))))
- (values operations
- environment
- (quotation/make block
- (integrate/expression operations
- environment
- expression)))
- ))))))
-
-(define (operations/bind-block operations block)
- (let ((declarations (block/declarations block)))
- (if (null? declarations)
- (operations/shadow operations (block/bound-variables block))
- (with-values (lambda () (declarations/binders declarations))
- (lambda (before-bindings after-bindings)
- (after-bindings
- (operations/shadow (before-bindings operations)
- (block/bound-variables block))))))))
+ (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 block expression))))))
(define (integrate/expressions operations environment expressions)
(map (lambda (expression)
(if (constant-value? value environment operations)
(if-win
(copy/expression/intern (reference/block reference)
- value
- #f))
+ value))
(if-fail)))))
(environment/lookup environment variable
(lambda (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)))))))))
+ (lambda (value*)
+ (check value* false))
+ (lambda ()
+ ;; unknown value
+ (operations/lookup operations var
+ (lambda (operation info)
+ operation info
+ false)
+ (lambda ()
+ ;; No operations
+ true)))
+ (lambda ()
+ ;; not found variable
+ true)))))))))
\f
(define (integrate/reference-operator operations environment operator operands)
(let ((variable (reference/variable operator)))
\f
;;;; Binding
-(define-method/integrate 'OPEN-BLOCK
- (lambda (operations environment expression)
+(define (integrate/open-block operations environment expression)
+ (let ((variables (open-block/variables expression))
+ (block (open-block/block expression)))
(let ((operations
- (operations/bind-block operations (open-block/block expression))))
- (process-block-flags (block/flags (open-block/block expression))
- (lambda ()
- (with-values
+ (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
- (open-block/variables expression)
+ variables
(open-block/values expression)))
- (lambda (environment vals)
- (integrate/open-block operations environment expression
- vals))))))))
+ (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 block variables vals actions true)
+ (open-block/optimizing-make
+ 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)
(fluid-let ((*block-optimizing-switch #F))
(process-block-flags (cdr flags) continuation)))
(else (error "Bad flag"))))))
-
-(define (integrate/open-block operations environment expression values)
- (let ((actions
- (integrate/actions operations environment
- (open-block/actions expression)))
- (vars (open-block/variables 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))))
- vars))
- (if (open-block/optimized expression)
- (open-block/make (open-block/block expression) vars values actions #t)
- (open-block/optimizing-make (open-block/block expression)
- vars
- values
- actions
- operations
- environment))))
\f
(define (variable/unreferenced? variable)
(and (not (variable/integrated variable))
(define *eta-substitution-switch #F)
\f
(define (integrate/procedure operations environment procedure)
- (let ((block (procedure/block procedure))
+ (let ((block (procedure/block procedure))
(required (procedure/required procedure))
(optional (procedure/optional procedure))
- (rest (procedure/rest 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 (operations/bind-block operations block)
- environment
- (procedure/body procedure))))
+ (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)
body))))))))
(define (match-up? operands required)
- (cond ((null? operands) (null? required))
- ((null? required) #f)
- (else (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)))))))
+ (if (null? operands)
+ (null? required)
+ (and (not (null? required))
+ (let ((this-operand (car operands))
+ (this-required (car required)))
+ (and (reference? this-operand)
+ (eq? (reference/variable this-operand) this-required)
+ (match-up? (cdr operands) (cdr required)))))))
\f
(define-method/integrate 'COMBINATION
(define-method/integrate 'DECLARATION
(lambda (operations environment declaration)
- (let ((declarations (declaration/declarations declaration)))
+ (let ((declarations (declaration/declarations declaration))
+ (expression (declaration/expression declaration)))
(declaration/make
declarations
- (with-values (lambda () (declarations/binders declarations))
- (lambda (before-bindings after-bindings)
- (integrate/expression (after-bindings (before-bindings operations))
- environment
- (declaration/expression declaration))))))))
+ (integrate/expression (declarations/bind operations declarations)
+ environment
+ expression)))))
\f
;;;; Easy Cases
(integrate/quotation (in-package/quotation expression)))))
(define (integrate/quotation quotation)
- (with-values
+ (call-with-values
(lambda ()
(integrate/top-level (quotation/block quotation)
(quotation/expression quotation)))
(define (integrate/name reference info environment if-integrated if-not)
(let ((variable (reference/variable reference)))
(let ((finish
- (lambda (value uninterned)
+ (lambda (value)
(if-integrated
- (copy/expression/intern (reference/block reference)
- value
- uninterned)))))
+ (copy/expression/intern (reference/block reference) value)))))
(if info
- (finish (integration-info/expression info)
- (integration-info/uninterned-variables 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 '())))
+ (finish (delayed-integration/force value)))
+ (finish value)))
if-not
if-not)))))
this-vars)))
(if (eq? this-type 'LET)
- (let ((block (block/make block true)))
- (set-block/bound-variables! block this-vars)
+ (let ((block (block/make block true this-vars)))
(loop (cdr template)
block
(combination/optimizing-make
false
code)
this-vals)))
- (let ((block (block/make block true)))
- (set-block/bound-variables! block this-vars)
+ (let ((block (block/make block true this-vars)))
(loop (cdr template)
block
(open-block/make
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/tables.scm,v 4.1 1988/06/13 12:31:31 cph Rel $
+$Id: tables.scm,v 4.2 1993/01/02 07:33:38 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+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
(cons '() '()))
(define (operations/lookup operations variable if-found if-not)
- (let ((entry (assq variable (car operations)))
- (finish
- (lambda (entry)
- (if-found (vector-ref (cdr entry) 1)
- (vector-ref (cdr entry) 2)))))
+ (let ((entry (assq variable (car operations))))
(if entry
- (if (cdr entry) (finish entry) (if-not))
- (let ((entry (assq (variable/name variable) (cdr operations))))
- (if entry (finish entry) (if-not))))))
+ (if (cdr entry)
+ (if-found (cadr entry) (cddr entry))
+ (if-not))
+ (let ((entry (assq variable (cdr operations))))
+ (if entry
+ (if-found (cadr entry) (cddr entry))
+ (if-not))))))
(define (operations/shadow operations variables)
(cons (map* (car operations)
variables)
(cdr operations)))
-(define (operations/bind-global operations operation export? names values)
- (cons (car operations)
- (map* (cdr operations)
- (lambda (name value)
- (cons name (vector export? operation value)))
- names values)))
-
-(define (operations/bind operations operation export? names values)
- (cons (let ((make-binding
- (lambda (name value)
- (cons name (vector export? operation value)))))
- (if (eq? values 'NO-VALUES)
- (map* (car operations)
- (lambda (name) (make-binding name false))
- names)
- (map* (car operations) make-binding names values)))
+(define (operations/bind operations operation variable value)
+ (cons (cons (cons* variable operation value)
+ (car operations))
(cdr operations)))
-(define (operations/extract-external operations procedure)
+(define (operations/bind-global operations operation variable value)
+ (cons (car operations)
+ (cons (cons* variable operation value)
+ (cdr operations))))
+
+(define (operations/map-external operations procedure)
(let loop ((elements (car operations)))
- (if (null? elements)
- '()
- (let ((value (cdar elements)) (rest (loop (cdr elements))))
- (if (and value (vector-ref value 0))
- (procedure (caar elements) (vector-ref value 1)
- (vector-ref value 2)
- (lambda (value) (cons value rest))
- (lambda () rest))
- rest)))))
\ No newline at end of file
+ (cond ((null? elements)
+ '())
+ ((cdar elements)
+ (cons (procedure (cadar elements) (caar elements) (cddar elements))
+ (loop (cdr elements))))
+ (else
+ (loop (cdr elements))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: toplev.scm,v 4.9 1992/11/04 10:17:39 jinx Exp $
+$Id: toplev.scm,v 4.10 1993/01/02 07:33:38 cph Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+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
(define (sf input-string #!optional bin-string spec-string)
(syntax-file input-string
- (if (default-object? bin-string) false bin-string)
- (if (default-object? spec-string) false spec-string)))
-
-#|
-(define (scold input-string #!optional bin-string spec-string)
- "Use this only for syntaxing the cold-load root file.
-Currently only the 68000 implementation needs this."
- (fluid-let ((wrapping-hook wrap-with-control-point))
- (syntax-file input-string bin-string spec-string)))
-|#
+ (and (not (default-object? bin-string)) bin-string)
+ (and (not (default-object? spec-string)) spec-string)))
(define (syntax&integrate s-expression declarations #!optional syntax-table)
(fluid-let ((sf:noisy? false))
\f
;;;; File Syntaxer
-(define sf/default-externs-pathname
- (make-pathname false false false false "ext" 'NEWEST))
-
-(define sfu? false)
-
(define (syntax-file input-string bin-string spec-string)
(if (not (or (false? sf/default-syntax-table)
(syntax-table? sf/default-syntax-table)))
- (error "Malformed binding of SF/DEFAULT-SYNTAX-TABLE"
+ (error "Malformed binding of SF/DEFAULT-SYNTAX-TABLE:"
sf/default-syntax-table))
(if (not (list-of-symbols? sf/top-level-definitions))
- (error "Malformed binding of SF/TOP-LEVEL-DEFINITIONS"
+ (error "Malformed binding of SF/TOP-LEVEL-DEFINITIONS:"
sf/top-level-definitions))
(for-each (lambda (input-string)
- (with-values
+ (call-with-values
(lambda ()
(sf/pathname-defaulting input-string
bin-string
spec-string))
(lambda (input-pathname bin-pathname spec-pathname)
- (with-values (lambda () (file-info/find input-pathname))
+ (call-with-values (lambda () (file-info/find input-pathname))
(lambda (syntax-table declarations)
(sf/internal input-pathname bin-pathname spec-pathname
syntax-table declarations))))))
(list input-string))))
(define (sf/pathname-defaulting input-string bin-string spec-string)
+ spec-string ;ignored
(let ((input-path (pathname/normalize input-string)))
- (let ((input-type (pathname-type input-path)))
- (let ((bin-path
- (let ((bin-path
- (pathname-new-type
- input-path
- (if (and (string? input-type)
- (not (string=? "scm" input-type)))
- (string-append "b" input-type)
- "bin"))))
- (if bin-string
- (merge-pathnames bin-string bin-path)
- bin-path))))
- (let ((spec-path
- (and (or spec-string sfu?)
- (let ((spec-path
- (pathname-new-type
- bin-path
- (if (and (string? input-type)
- (not (string=? "scm" input-type)))
- (string-append "u" input-type)
- "unf"))))
- (if spec-string
- (merge-pathnames spec-string spec-path)
- spec-path)))))
- (values input-path bin-path spec-path))))))
+ (values input-path
+ (let ((bin-path
+ (pathname-new-type
+ input-path
+ (let ((input-type (pathname-type input-path)))
+ (if (and (string? input-type)
+ (not (string=? "scm" input-type)))
+ (string-append "b" input-type)
+ "bin")))))
+ (if bin-string
+ (merge-pathnames bin-string bin-path)
+ bin-path))
+ false)))
\f
(define (sf/internal input-pathname bin-pathname spec-pathname
syntax-table declarations)
+ spec-pathname ;ignored
+ (let ((start-date (get-decoded-time)))
+ (if sf:noisy?
+ (begin
+ (newline)
+ (write-string "Syntax file: ")
+ (write (enough-namestring input-pathname))
+ (write-string " ")
+ (write (enough-namestring bin-pathname))))
+ (fasdump (make-comment
+ `((SOURCE-FILE . ,(->namestring input-pathname))
+ (DATE ,(decoded-time/year start-date)
+ ,(decoded-time/month start-date)
+ ,(decoded-time/day start-date))
+ (TIME ,(decoded-time/hour start-date)
+ ,(decoded-time/minute start-date)
+ ,(decoded-time/second start-date)))
+ (sf/file->scode input-pathname bin-pathname
+ syntax-table declarations))
+ bin-pathname)))
+
+(define (sf/file->scode input-pathname output-pathname
+ syntax-table declarations)
(fluid-let ((sf/default-externs-pathname
(make-pathname (pathname-host input-pathname)
(pathname-device input-pathname)
(pathname-directory input-pathname)
false
- "ext"
+ externs-pathname-type
'NEWEST)))
- (let ((start-date (get-decoded-time)))
- (if sf:noisy?
- (begin
- (newline)
- (write-string "Syntax file: ")
- (write (enough-namestring input-pathname))
- (write-string " ")
- (write (enough-namestring bin-pathname))
- (if spec-pathname
- (begin
- (write-string " ")
- (write (enough-namestring spec-pathname))))))
- (with-values
- (lambda ()
- (integrate/file input-pathname syntax-table declarations
- spec-pathname))
- (lambda (expression externs events)
- (fasdump (wrapping-hook
- (make-comment
- `((SOURCE-FILE . ,(->namestring input-pathname))
- (DATE ,(decoded-time/year start-date)
- ,(decoded-time/month start-date)
- ,(decoded-time/day start-date))
- (TIME ,(decoded-time/hour start-date)
- ,(decoded-time/minute start-date)
- ,(decoded-time/second start-date)))
- (set! expression false)))
- bin-pathname)
- (write-externs-file (pathname-new-type
- bin-pathname
- (pathname-type sf/default-externs-pathname))
- (set! externs false))
- (if spec-pathname
- (begin (if sf:noisy?
- (begin
- (newline)
- (write-string "Writing ")
- (write (enough-namestring spec-pathname))))
- (with-output-to-file spec-pathname
- (lambda ()
- (newline)
- (write `(DATE ,(decoded-time/year start-date)
- ,(decoded-time/month start-date)
- ,(decoded-time/day start-date)
- ,(decoded-time/hour start-date)
- ,(decoded-time/minute start-date)
- ,(decoded-time/second start-date)))
- (newline)
- (write `(SOURCE-FILE ,(->namestring input-pathname)))
- (newline)
- (write `(BINARY-FILE ,(->namestring bin-pathname)))
- (for-each (lambda (event)
- (newline)
- (write `(,(car event)
- (RUNTIME ,(cdr event)))))
- events)))
- (if sf:noisy?
- (write-string " -- done")))))))))
+ (call-with-values
+ (lambda ()
+ (integrate/file input-pathname syntax-table declarations))
+ (lambda (expression externs-block externs)
+ (if output-pathname
+ (write-externs-file (pathname-new-type output-pathname
+ externs-pathname-type)
+ externs-block
+ externs))
+ expression))))
+
+(define externs-pathname-type
+ "ext")
+
+(define sf/default-externs-pathname
+ (make-pathname false false false false externs-pathname-type 'NEWEST))
\f
(define (read-externs-file pathname)
(let ((pathname (merge-pathnames pathname sf/default-externs-pathname)))
- (if (file-exists? pathname)
- (fasload pathname)
- (begin
- (warn "Nonexistent externs file" (->namestring pathname))
- '()))))
+ (let ((namestring (->namestring pathname)))
+ (if (file-exists? pathname)
+ (let ((object (fasload pathname))
+ (wrong-version
+ (lambda (version)
+ (warn (string-append
+ "Externs file is wrong version (expected "
+ (number->string externs-file-version)
+ ", found "
+ (number->string version)
+ "):")
+ namestring)
+ (values false '()))))
+ (cond ((and (vector? object)
+ (>= (vector-length object) 4)
+ (eq? externs-file-tag (vector-ref object 0))
+ (exact-integer? (vector-ref object 1))
+ (>= (vector-ref object 1) 2))
+ (if (= externs-file-version (vector-ref object 1))
+ (values (vector-ref object 2) (vector-ref object 3))
+ (wrong-version (vector-ref object 1))))
+ ((and (list? object)
+ (for-all? object
+ (lambda (element)
+ (and (vector? element)
+ (= 4 (vector-length element))))))
+ (wrong-version 1))
+ (else
+ (error "Not an externs file:" namestring))))
+ (begin
+ (warn "Nonexistent externs file:" namestring)
+ (values false '()))))))
-(define (write-externs-file pathname externs)
+(define (write-externs-file pathname externs-block externs)
(cond ((not (null? externs))
- (fasdump externs pathname))
+ (fasdump (vector externs-file-tag externs-file-version
+ externs-block externs)
+ pathname))
((file-exists? pathname)
(delete-file pathname))))
-(define (wrapping-hook scode)
- scode)
-
-#|
-(define control-point-tail
- `(3 ,(object-new-type (microcode-type 'NULL) 16)
- () () () () () () () () () () () () () () ()))
-
-(define (wrap-with-control-point scode)
- (system-list->vector type-code-control-point
- `(,return-address-restart-execution
- ,scode
- ,system-global-environment
- ,return-address-non-existent-continuation
- ,@control-point-tail)))
-
-(define type-code-control-point
- (microcode-type 'CONTROL-POINT))
-
-(define return-address-restart-execution
- (make-return-address (microcode-return 'RESTART-EXECUTION)))
+(define externs-file-tag
+ (string->symbol "#[(scode-optimizer top-level)externs-file]"))
-(define return-address-non-existent-continuation
- (make-return-address (microcode-return 'NON-EXISTENT-CONTINUATION)))
-|#
+(define externs-file-version
+ 2)
\f
;;;; Optimizer Top Level
-(define (integrate/file file-name syntax-table declarations compute-free?)
- compute-free? ;ignored
+(define (integrate/file file-name syntax-table declarations)
(integrate/kernel (lambda ()
(phase:syntax (phase:read file-name) syntax-table))
declarations))
(define (integrate/simple preprocessor input declarations receiver)
- (with-values
+ (call-with-values
(lambda ()
(integrate/kernel (lambda () (preprocessor input)) declarations))
(or receiver
- (lambda (expression externs events)
- externs events ;ignored
+ (lambda (expression externs-block externs)
+ externs-block externs ;ignored
expression))))
(define (integrate/kernel get-scode declarations)
(fluid-let ((previous-name false)
(previous-process-time false)
- (previous-real-time false)
- (events '()))
- (with-values
+ (previous-real-time false))
+ (call-with-values
(lambda ()
- (with-values
+ (call-with-values
(lambda ()
- (with-values
+ (call-with-values
(lambda ()
(phase:transform (canonicalize-scode (get-scode)
declarations)))
phase:optimize))
phase:generate-scode))
- (lambda (externs expression)
+ (lambda (expression externs-block externs)
(end-phase)
- (values expression externs (reverse! events))))))
+ (values expression externs-block externs)))))
(define (canonicalize-scode scode declarations)
(let ((declarations (process-declarations declarations)))
(define (phase:generate-scode operations environment expression)
(mark-phase "Generate SCode")
- (values (operations->external operations environment)
- (cgen/external expression)))
+ (call-with-values (lambda () (operations->external operations environment))
+ (lambda (externs-block externs)
+ (values (cgen/external expression) externs-block externs))))
(define previous-name)
(define previous-process-time)
(define previous-real-time)
-(define events)
(define (mark-phase this-name)
(end-phase)
(write-string " ")
(write-string this-name)
(write-string "...")))
- (set! previous-name this-name))
+ (set! previous-name this-name)
+ unspecific)
(define (end-phase)
(let ((this-process-time (process-time-clock))
(this-real-time (real-time-clock)))
(if previous-process-time
(let ((delta-process-time (- this-process-time previous-process-time)))
- (set! events (cons (cons previous-name delta-process-time) events))
(time-report " Time taken"
delta-process-time
(- this-real-time previous-real-time))))
(set! previous-process-time this-process-time)
- (set! previous-real-time this-real-time)))
+ (set! previous-real-time this-real-time))
+ unspecific)
;; Should match the compiler. We'll merge the two at some point.
(define (time-report prefix process-time real-time)
#| -*-Scheme-*-
-$Id: usiexp.scm,v 4.13 1992/12/22 21:00:55 cph Exp $
+$Id: usiexp.scm,v 4.14 1993/01/02 07:33:39 cph Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+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
;;; package: (scode-optimizer expansion)
(declare (usual-integrations)
- (automagic-integrations)
- (open-block-optimizations)
- (eta-substitution)
(integrate-external "object"))
\f
;;;; Fixed-arity arithmetic primitives
(define (values-expansion operands if-expanded if-not-expanded block)
if-not-expanded
(if-expanded
- (let ((block (block/make block true)))
+ (let ((block (block/make block true '())))
(let ((variables
(map (lambda (operand)
operand
- (variable/make block
- (string->uninterned-symbol "value")
- '()))
+ (variable/make&bind! block
+ (string->uninterned-symbol "value")))
operands)))
- (set-block/bound-variables! block variables)
(combination/make
(procedure/make
block lambda-tag:let variables '() false
- (let ((block (block/make block true)))
- (let ((variable (variable/make block 'RECEIVER '())))
- (let ((variables* (list variable)))
- (set-block/bound-variables! block variables*)
- (procedure/make
- block lambda-tag:unnamed variables* '() false
- (combination/make (reference/make block variable)
- (map (lambda (variable)
- (reference/make block variable))
- variables)))))))
+ (let ((block (block/make block true '())))
+ (let ((variable (variable/make&bind! block 'RECEIVER)))
+ (procedure/make
+ block lambda-tag:unnamed (list variable) '() false
+ (combination/make (reference/make block variable)
+ (map (lambda (variable)
+ (reference/make block variable))
+ variables))))))
operands)))))
(define (call-with-values-expansion operands if-expanded if-not-expanded block)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/xform.scm,v 4.3 1990/06/11 16:34:51 jinx Rel $
+$Id: xform.scm,v 4.4 1993/01/02 07:33:39 cph Exp $
-Copyright (c) 1988, 1990 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
;;;; SCode Optimizer: Transform Input Expression
(declare (usual-integrations)
- (eta-substitution)
- (automagic-integrations)
- (open-block-optimizations)
(integrate-external "object"))
\f
-;;; GLOBAL-BLOCK is used to handle (USUAL-INTEGRATIONS), as follows.
-;;; This declaration refers to a large group of names, which are
-;;; normally defined in the global environment. Names in this group
-;;; are supposed to be shadowed by top-level definitions in the user's
-;;; program.
-
-;;; Normally we would intern the variable objects corresponding to
-;;; those names in the block corresponding to the outermost
-;;; environment in the user's program. However, if the user had a
-;;; top-level definition which was intended to shadow one of those
-;;; names, both the definition and the declaration would refer to the
-;;; same variable object. So, instead we intern them in GLOBAL-BLOCK,
-;;; which never has any user defined names in it.
-
(define (transform/top-level expression shadowed-names)
- (let ((block (block/make (block/make false false) false)))
- (set-block/bound-variables!
- block
- (map (lambda (name) (variable/make block name '())) shadowed-names))
+ (let ((block (block/make false false '())))
+ (for-each (lambda (name)
+ (variable/make&bind! block name))
+ shadowed-names)
(values block (transform/top-level-1 true block block expression))))
(define (transform/recursive block top-level-block expression)
- (transform/top-level-1 false block top-level-block expression))
+ (transform/top-level-1 false top-level-block block expression))
(define top-level?)
-(define global-block)
-
-(define (transform/top-level-1 top? block top-level-block expression)
- (fluid-let ((top-level? top?)
- (global-block
- (let block/global-parent ((block top-level-block))
- (if (block/parent block)
- (block/global-parent (block/parent block))
- block))))
+(define top-level-block)
+(define root-block)
+
+(define (transform/top-level-1 tl? tl-block block expression)
+ (fluid-let ((top-level? tl?)
+ (top-level-block tl-block)
+ (root-block block))
(let ((environment
(if top-level?
(environment/bind (environment/make)
- (block/bound-variables block))
+ (block/bound-variables-list block))
(environment/make))))
(if (scode-open-block? expression)
(begin
(if (not top-level?)
- (error "TRANSFORM/TOP-LEVEL-1: open blocks disallowed"
- expression))
- (open-block-components expression
- (transform/open-block* block environment)))
+ (error "Open blocks allowed only at top level:" expression))
+ (call-with-values
+ (lambda () (open-block-components expression values))
+ (lambda (auxiliary declarations body)
+ (transform/open-block* block
+ environment
+ auxiliary
+ declarations
+ body))))
(transform/expression block environment expression)))))
(define (transform/expressions block environment expressions)
(define (environment/make)
'())
-(define (environment/lookup block environment name)
+(define (environment/lookup environment name)
(let ((association (assq name environment)))
(if association
(cdr association)
- (or (and (not top-level?)
- (block/lookup-name block name false))
- (block/lookup-name global-block name true)))))
+ (or (block/lookup-name root-block name false)
+ (variable/make&bind! top-level-block name)))))
(define (environment/bind environment variables)
(map* environment
variables))
\f
(define (transform/open-block block environment expression)
- (open-block-components expression
- (transform/open-block* (block/make block true) environment)))
-
-(define ((transform/open-block* block environment) auxiliary declarations body)
- (let ((variables (map (lambda (name) (variable/make block name '()))
- auxiliary)))
- (set-block/bound-variables! block
- (append (block/bound-variables block)
- variables))
+ (call-with-values (lambda () (open-block-components expression values))
+ (lambda (auxiliary declarations body)
+ (transform/open-block* (block/make block true '())
+ environment
+ auxiliary
+ declarations
+ body))))
+
+(define (transform/open-block* block environment auxiliary declarations body)
+ (let ((variables
+ (map (lambda (name) (variable/make&bind! block name))
+ auxiliary)))
(set-block/declarations! block (declarations/parse block declarations))
- (let ((environment (environment/bind environment variables)))
-
- (define (loop variables actions)
- (cond ((null? variables)
- (values '() (map transform actions)))
- ((null? actions)
- (error "Extraneous auxiliaries" variables))
-
- ;; Because `scan-defines' returns the auxiliary names in a
- ;; particular order, we can expect to encounter them in that
- ;; same order when looking through the body's actions.
-
- ((and (scode-assignment? (car actions))
- (eq? (assignment-name (car actions))
- (variable/name (car variables))))
- (with-values (lambda () (loop (cdr variables) (cdr actions)))
- (lambda (vals actions*)
- (values
- (cons (transform (assignment-value (car actions))) vals)
- (cons open-block/value-marker actions*)))))
- (else
- (with-values (lambda () (loop variables (cdr actions)))
- (lambda (vals actions*)
- (values vals (cons (transform (car actions)) actions*)))))))
-
- (define-integrable (transform subexpression)
- (transform/expression block environment subexpression))
-
- (with-values (lambda () (loop variables (sequence-actions body)))
- (lambda (vals actions)
- (open-block/make block variables vals actions false))))))
+ (call-with-values
+ (lambda ()
+ (let ((environment (environment/bind environment variables)))
+ (let ((transform
+ (lambda (subexpression)
+ (transform/expression block environment subexpression))))
+ (let loop
+ ((variables variables)
+ (actions (sequence-actions body)))
+ (cond ((null? variables)
+ (values '() (map transform actions)))
+ ((null? actions)
+ (error "Extraneous auxiliaries" variables))
+ ;; Because `scan-defines' returns the auxiliary
+ ;; names in a particular order, we can expect to
+ ;; encounter them in that same order when
+ ;; looking through the body's actions.
+ ((and (scode-assignment? (car actions))
+ (eq? (assignment-name (car actions))
+ (variable/name (car variables))))
+ (call-with-values
+ (lambda () (loop (cdr variables) (cdr actions)))
+ (lambda (vals actions*)
+ (values
+ (cons (transform (assignment-value (car actions)))
+ vals)
+ (cons open-block/value-marker actions*)))))
+ (else
+ (call-with-values
+ (lambda () (loop variables (cdr actions)))
+ (lambda (vals actions*)
+ (values vals
+ (cons (transform (car actions))
+ actions*))))))))))
+ (lambda (vals actions)
+ (open-block/make block variables vals actions false)))))
(define (transform/variable block environment expression)
(reference/make block
- (environment/lookup block
- environment
+ (environment/lookup environment
(variable-name expression))))
(define (transform/assignment block environment expression)
(assignment-components expression
(lambda (name value)
- (let ((variable (environment/lookup block environment name)))
+ (let ((variable (environment/lookup environment name)))
(variable/side-effect! variable)
(assignment/make block
variable
(define (transform/lambda block environment expression)
(lambda-components* expression
(lambda (name required optional rest body)
- (let ((block (block/make block true)))
- (with-values
+ (let ((block (block/make block true '())))
+ (call-with-values
(lambda ()
(let ((name->variable
- (lambda (name) (variable/make block name '()))))
+ (lambda (name) (variable/make&bind! block name))))
(values (map name->variable required)
(map name->variable optional)
(and rest (name->variable rest)))))
(lambda (required optional rest)
- (let* ((bound `(,@required ,@optional ,@(if rest `(,rest) '())))
- (environment (environment/bind environment bound)))
- (set-block/bound-variables! block bound)
+ (let ((environment
+ (environment/bind environment
+ (block/bound-variables-list block))))
(procedure/make
block name required optional rest
(transform/procedure-body block
(transform/expression block environment body))
(transform/open-block block environment expression))))
(transform/expression block environment expression)))
-\f
-#|
-;; In-package no longer scans the body, so definitions at top-level are legal.
(define (transform/definition block environment expression)
- block environment ; ignored
(definition-components expression
(lambda (name value)
- value ; ignored
- (error "Unscanned definition encountered. Unable to proceed." name))))
-|#
-
-(define (transform/definition block environment expression)
- (definition-components expression
- (lambda (name value)
- (if (not (top-level-block? block))
- (error "Unscanned definition encountered. Unable to proceed." name)
- (transform/combination
- block environment
- (make-combination
- (make-primitive-procedure 'local-assignment)
- (list (make-the-environment)
- name
- value)))))))
-
-;; Kludge!
-
-(define (top-level-block? block)
- (let ((parent (block/parent block)))
- (and parent (eq? parent global-block))))
+ (if (not (eq? block top-level-block))
+ (error "Unscanned definition encountered (unable to proceed):" name))
+ (transform/combination
+ block environment
+ (make-combination (make-primitive-procedure 'LOCAL-ASSIGNMENT)
+ (list (make-the-environment) name value))))))
(define (transform/access block environment expression)
(access-components expression
(transform/expression block environment predicate)
(transform/expression block environment alternative)))))
-(define (transform/error-combination block environment expression)
- (combination-components expression
- (lambda (operator operands)
- (combination/make
- (transform/expression block environment operator)
- (list (transform/expression block environment (car operands))
- (transform/expression block environment (cadr operands))
- (the-environment/make block))))))
-
(define (transform/in-package block environment expression)
(in-package-components expression
(lambda (environment* expression)
(transform/quotation* (quotation-expression expression)))
(define (transform/quotation* expression)
- (with-values (lambda () (transform/top-level expression '()))
+ (call-with-values (lambda () (transform/top-level expression '()))
quotation/make))
(define (transform/sequence block environment expression)
(sequence/make
(transform/expressions block environment (sequence-actions expression))))
-\f
+
(define (transform/the-environment block environment expression)
environment expression ; ignored
(block/unsafe! block)
(DEFINITION ,transform/definition)
(DELAY ,transform/delay)
(DISJUNCTION ,transform/disjunction)
- (ERROR-COMBINATION ,transform/error-combination)
(IN-PACKAGE ,transform/in-package)
(LAMBDA ,transform/lambda)
(OPEN-BLOCK ,transform/open-block)
#| -*-Scheme-*-
-$Id: make.scm,v 4.25 1992/12/02 19:36:41 cph Exp $
+$Id: make.scm,v 4.26 1993/01/02 07:33:35 cph Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+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
(package/system-loader "sf" '() 'QUERY)
((package/reference (find-package '(SCODE-OPTIMIZER))
'USUAL-INTEGRATIONS/CACHE!))
-(add-system! (make-system "SF" 4 25 '()))
\ No newline at end of file
+(add-system! (make-system "SF" 4 26 '()))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: toplev.scm,v 4.9 1992/11/04 10:17:39 jinx Exp $
+$Id: toplev.scm,v 4.10 1993/01/02 07:33:38 cph Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+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
(define (sf input-string #!optional bin-string spec-string)
(syntax-file input-string
- (if (default-object? bin-string) false bin-string)
- (if (default-object? spec-string) false spec-string)))
-
-#|
-(define (scold input-string #!optional bin-string spec-string)
- "Use this only for syntaxing the cold-load root file.
-Currently only the 68000 implementation needs this."
- (fluid-let ((wrapping-hook wrap-with-control-point))
- (syntax-file input-string bin-string spec-string)))
-|#
+ (and (not (default-object? bin-string)) bin-string)
+ (and (not (default-object? spec-string)) spec-string)))
(define (syntax&integrate s-expression declarations #!optional syntax-table)
(fluid-let ((sf:noisy? false))
\f
;;;; File Syntaxer
-(define sf/default-externs-pathname
- (make-pathname false false false false "ext" 'NEWEST))
-
-(define sfu? false)
-
(define (syntax-file input-string bin-string spec-string)
(if (not (or (false? sf/default-syntax-table)
(syntax-table? sf/default-syntax-table)))
- (error "Malformed binding of SF/DEFAULT-SYNTAX-TABLE"
+ (error "Malformed binding of SF/DEFAULT-SYNTAX-TABLE:"
sf/default-syntax-table))
(if (not (list-of-symbols? sf/top-level-definitions))
- (error "Malformed binding of SF/TOP-LEVEL-DEFINITIONS"
+ (error "Malformed binding of SF/TOP-LEVEL-DEFINITIONS:"
sf/top-level-definitions))
(for-each (lambda (input-string)
- (with-values
+ (call-with-values
(lambda ()
(sf/pathname-defaulting input-string
bin-string
spec-string))
(lambda (input-pathname bin-pathname spec-pathname)
- (with-values (lambda () (file-info/find input-pathname))
+ (call-with-values (lambda () (file-info/find input-pathname))
(lambda (syntax-table declarations)
(sf/internal input-pathname bin-pathname spec-pathname
syntax-table declarations))))))
(list input-string))))
(define (sf/pathname-defaulting input-string bin-string spec-string)
+ spec-string ;ignored
(let ((input-path (pathname/normalize input-string)))
- (let ((input-type (pathname-type input-path)))
- (let ((bin-path
- (let ((bin-path
- (pathname-new-type
- input-path
- (if (and (string? input-type)
- (not (string=? "scm" input-type)))
- (string-append "b" input-type)
- "bin"))))
- (if bin-string
- (merge-pathnames bin-string bin-path)
- bin-path))))
- (let ((spec-path
- (and (or spec-string sfu?)
- (let ((spec-path
- (pathname-new-type
- bin-path
- (if (and (string? input-type)
- (not (string=? "scm" input-type)))
- (string-append "u" input-type)
- "unf"))))
- (if spec-string
- (merge-pathnames spec-string spec-path)
- spec-path)))))
- (values input-path bin-path spec-path))))))
+ (values input-path
+ (let ((bin-path
+ (pathname-new-type
+ input-path
+ (let ((input-type (pathname-type input-path)))
+ (if (and (string? input-type)
+ (not (string=? "scm" input-type)))
+ (string-append "b" input-type)
+ "bin")))))
+ (if bin-string
+ (merge-pathnames bin-string bin-path)
+ bin-path))
+ false)))
\f
(define (sf/internal input-pathname bin-pathname spec-pathname
syntax-table declarations)
+ spec-pathname ;ignored
+ (let ((start-date (get-decoded-time)))
+ (if sf:noisy?
+ (begin
+ (newline)
+ (write-string "Syntax file: ")
+ (write (enough-namestring input-pathname))
+ (write-string " ")
+ (write (enough-namestring bin-pathname))))
+ (fasdump (make-comment
+ `((SOURCE-FILE . ,(->namestring input-pathname))
+ (DATE ,(decoded-time/year start-date)
+ ,(decoded-time/month start-date)
+ ,(decoded-time/day start-date))
+ (TIME ,(decoded-time/hour start-date)
+ ,(decoded-time/minute start-date)
+ ,(decoded-time/second start-date)))
+ (sf/file->scode input-pathname bin-pathname
+ syntax-table declarations))
+ bin-pathname)))
+
+(define (sf/file->scode input-pathname output-pathname
+ syntax-table declarations)
(fluid-let ((sf/default-externs-pathname
(make-pathname (pathname-host input-pathname)
(pathname-device input-pathname)
(pathname-directory input-pathname)
false
- "ext"
+ externs-pathname-type
'NEWEST)))
- (let ((start-date (get-decoded-time)))
- (if sf:noisy?
- (begin
- (newline)
- (write-string "Syntax file: ")
- (write (enough-namestring input-pathname))
- (write-string " ")
- (write (enough-namestring bin-pathname))
- (if spec-pathname
- (begin
- (write-string " ")
- (write (enough-namestring spec-pathname))))))
- (with-values
- (lambda ()
- (integrate/file input-pathname syntax-table declarations
- spec-pathname))
- (lambda (expression externs events)
- (fasdump (wrapping-hook
- (make-comment
- `((SOURCE-FILE . ,(->namestring input-pathname))
- (DATE ,(decoded-time/year start-date)
- ,(decoded-time/month start-date)
- ,(decoded-time/day start-date))
- (TIME ,(decoded-time/hour start-date)
- ,(decoded-time/minute start-date)
- ,(decoded-time/second start-date)))
- (set! expression false)))
- bin-pathname)
- (write-externs-file (pathname-new-type
- bin-pathname
- (pathname-type sf/default-externs-pathname))
- (set! externs false))
- (if spec-pathname
- (begin (if sf:noisy?
- (begin
- (newline)
- (write-string "Writing ")
- (write (enough-namestring spec-pathname))))
- (with-output-to-file spec-pathname
- (lambda ()
- (newline)
- (write `(DATE ,(decoded-time/year start-date)
- ,(decoded-time/month start-date)
- ,(decoded-time/day start-date)
- ,(decoded-time/hour start-date)
- ,(decoded-time/minute start-date)
- ,(decoded-time/second start-date)))
- (newline)
- (write `(SOURCE-FILE ,(->namestring input-pathname)))
- (newline)
- (write `(BINARY-FILE ,(->namestring bin-pathname)))
- (for-each (lambda (event)
- (newline)
- (write `(,(car event)
- (RUNTIME ,(cdr event)))))
- events)))
- (if sf:noisy?
- (write-string " -- done")))))))))
+ (call-with-values
+ (lambda ()
+ (integrate/file input-pathname syntax-table declarations))
+ (lambda (expression externs-block externs)
+ (if output-pathname
+ (write-externs-file (pathname-new-type output-pathname
+ externs-pathname-type)
+ externs-block
+ externs))
+ expression))))
+
+(define externs-pathname-type
+ "ext")
+
+(define sf/default-externs-pathname
+ (make-pathname false false false false externs-pathname-type 'NEWEST))
\f
(define (read-externs-file pathname)
(let ((pathname (merge-pathnames pathname sf/default-externs-pathname)))
- (if (file-exists? pathname)
- (fasload pathname)
- (begin
- (warn "Nonexistent externs file" (->namestring pathname))
- '()))))
+ (let ((namestring (->namestring pathname)))
+ (if (file-exists? pathname)
+ (let ((object (fasload pathname))
+ (wrong-version
+ (lambda (version)
+ (warn (string-append
+ "Externs file is wrong version (expected "
+ (number->string externs-file-version)
+ ", found "
+ (number->string version)
+ "):")
+ namestring)
+ (values false '()))))
+ (cond ((and (vector? object)
+ (>= (vector-length object) 4)
+ (eq? externs-file-tag (vector-ref object 0))
+ (exact-integer? (vector-ref object 1))
+ (>= (vector-ref object 1) 2))
+ (if (= externs-file-version (vector-ref object 1))
+ (values (vector-ref object 2) (vector-ref object 3))
+ (wrong-version (vector-ref object 1))))
+ ((and (list? object)
+ (for-all? object
+ (lambda (element)
+ (and (vector? element)
+ (= 4 (vector-length element))))))
+ (wrong-version 1))
+ (else
+ (error "Not an externs file:" namestring))))
+ (begin
+ (warn "Nonexistent externs file:" namestring)
+ (values false '()))))))
-(define (write-externs-file pathname externs)
+(define (write-externs-file pathname externs-block externs)
(cond ((not (null? externs))
- (fasdump externs pathname))
+ (fasdump (vector externs-file-tag externs-file-version
+ externs-block externs)
+ pathname))
((file-exists? pathname)
(delete-file pathname))))
-(define (wrapping-hook scode)
- scode)
-
-#|
-(define control-point-tail
- `(3 ,(object-new-type (microcode-type 'NULL) 16)
- () () () () () () () () () () () () () () ()))
-
-(define (wrap-with-control-point scode)
- (system-list->vector type-code-control-point
- `(,return-address-restart-execution
- ,scode
- ,system-global-environment
- ,return-address-non-existent-continuation
- ,@control-point-tail)))
-
-(define type-code-control-point
- (microcode-type 'CONTROL-POINT))
-
-(define return-address-restart-execution
- (make-return-address (microcode-return 'RESTART-EXECUTION)))
+(define externs-file-tag
+ (string->symbol "#[(scode-optimizer top-level)externs-file]"))
-(define return-address-non-existent-continuation
- (make-return-address (microcode-return 'NON-EXISTENT-CONTINUATION)))
-|#
+(define externs-file-version
+ 2)
\f
;;;; Optimizer Top Level
-(define (integrate/file file-name syntax-table declarations compute-free?)
- compute-free? ;ignored
+(define (integrate/file file-name syntax-table declarations)
(integrate/kernel (lambda ()
(phase:syntax (phase:read file-name) syntax-table))
declarations))
(define (integrate/simple preprocessor input declarations receiver)
- (with-values
+ (call-with-values
(lambda ()
(integrate/kernel (lambda () (preprocessor input)) declarations))
(or receiver
- (lambda (expression externs events)
- externs events ;ignored
+ (lambda (expression externs-block externs)
+ externs-block externs ;ignored
expression))))
(define (integrate/kernel get-scode declarations)
(fluid-let ((previous-name false)
(previous-process-time false)
- (previous-real-time false)
- (events '()))
- (with-values
+ (previous-real-time false))
+ (call-with-values
(lambda ()
- (with-values
+ (call-with-values
(lambda ()
- (with-values
+ (call-with-values
(lambda ()
(phase:transform (canonicalize-scode (get-scode)
declarations)))
phase:optimize))
phase:generate-scode))
- (lambda (externs expression)
+ (lambda (expression externs-block externs)
(end-phase)
- (values expression externs (reverse! events))))))
+ (values expression externs-block externs)))))
(define (canonicalize-scode scode declarations)
(let ((declarations (process-declarations declarations)))
(define (phase:generate-scode operations environment expression)
(mark-phase "Generate SCode")
- (values (operations->external operations environment)
- (cgen/external expression)))
+ (call-with-values (lambda () (operations->external operations environment))
+ (lambda (externs-block externs)
+ (values (cgen/external expression) externs-block externs))))
(define previous-name)
(define previous-process-time)
(define previous-real-time)
-(define events)
(define (mark-phase this-name)
(end-phase)
(write-string " ")
(write-string this-name)
(write-string "...")))
- (set! previous-name this-name))
+ (set! previous-name this-name)
+ unspecific)
(define (end-phase)
(let ((this-process-time (process-time-clock))
(this-real-time (real-time-clock)))
(if previous-process-time
(let ((delta-process-time (- this-process-time previous-process-time)))
- (set! events (cons (cons previous-name delta-process-time) events))
(time-report " Time taken"
delta-process-time
(- this-real-time previous-real-time))))
(set! previous-process-time this-process-time)
- (set! previous-real-time this-real-time)))
+ (set! previous-real-time this-real-time))
+ unspecific)
;; Should match the compiler. We'll merge the two at some point.
(define (time-report prefix process-time real-time)
projects / mit-scheme.git / commitdiff