From af5215b750b9491af517dab3b3c25965f2c9edf5 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 2 Jan 1993 07:33:39 +0000 Subject: [PATCH] Complete redesign of environment model and declaration parser. This was prompted by a bug that had been present since the original design; the bug was inherent in the design, hence the need for a redesign. The new design has the following features: * The old design used a two-level environment model for the top-level environment, in which imported and global bindings were distinguished from top-level bindings appearing in the file. The new design uses a single top-level environment for all bindings. This is the change fixed the bug, but introduced performance problems because the two-level design had a special hack for the global environment; the performance problems were fixed by: * The new design uses a hash table to hold the bindings in (the model of) an environment frame when the number of bindings exceeds a preset threshold. This allows very large environment frames to have reasonable access times, while avoiding the time and space overhead of the hash table for small environment frames; typically only a few frames will use the hash table mechanism. The hash table uses open addressing with double hashing. * Because ".ext" files are internal data structures that are written to a file, old ".ext" files are incompatible with the new scode optimizer. In order to prevent lossage, ".ext" files have a new format, which contains a version number. When the scode optimizer encounters an old ".ext" file, or a new one with the wrong version number, it will emit a warning and ignore it. * Code that supported special "error combinations" has been removed, since these are no longer used. * Code that generated ".unf" files has been removed. Since several procedures with semi-public interfaces accept arguments or return values relating to these files, the procedures ignore such arguments and return dummy values. The global variable SFU? has been eliminated. --- v7/src/sf/chtype.scm | 16 +- v7/src/sf/copy.scm | 206 ++++++------- v7/src/sf/emodel.scm | 187 ++++++++++-- v7/src/sf/free.scm | 18 +- v7/src/sf/make.scm | 6 +- v7/src/sf/object.scm | 233 +++++++-------- v7/src/sf/pardec.scm | 689 ++++++++++++++++++++----------------------- v7/src/sf/reduct.scm | 22 +- v7/src/sf/sf.pkg | 21 +- v7/src/sf/subst.scm | 226 +++++++------- v7/src/sf/tables.scm | 62 ++-- v7/src/sf/toplev.scm | 273 ++++++++--------- v7/src/sf/usiexp.scm | 33 +-- v7/src/sf/xform.scm | 220 ++++++-------- v8/src/sf/make.scm | 6 +- v8/src/sf/toplev.scm | 273 ++++++++--------- 16 files changed, 1194 insertions(+), 1297 deletions(-) diff --git a/v7/src/sf/chtype.scm b/v7/src/sf/chtype.scm index 570763b4b..4416e72b5 100644 --- a/v7/src/sf/chtype.scm +++ b/v7/src/sf/chtype.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -35,19 +35,13 @@ MIT in each case. |# ;;;; SCode Optimizer: Intern object types (declare (usual-integrations) - (automagic-integrations) (integrate-external "object")) -(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) diff --git a/v7/src/sf/copy.scm b/v7/src/sf/copy.scm index 8af62b479..391febbde 100644 --- a/v7/src/sf/copy.scm +++ b/v7/src/sf/copy.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -35,39 +35,29 @@ MIT in each case. |# ;;;; SCode Optimizer: Copy Expression (declare (usual-integrations) - (open-block-optimizations) - (eta-substitution) - (automagic-integrations) (integrate-external "object")) (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)) @@ -78,6 +68,32 @@ MIT in each case. |# (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))))) + (define (copy/quotation quotation) (fluid-let ((root-block false)) (let ((block (quotation/block quotation)) @@ -86,61 +102,56 @@ MIT in each case. |# (copy/expression block environment (quotation/expression quotation)))))) - + (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))) - -(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 @@ -158,40 +169,14 @@ MIT in each case. |# (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))))) (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)))) @@ -204,45 +189,29 @@ MIT in each case. |# (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))))) @@ -250,12 +219,13 @@ MIT in each case. |# (lambda (block environment expression) (delay/make (copy/expression block environment (delay/expression expression))))) - + (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 @@ -263,10 +233,10 @@ MIT in each case. |# (in-package/make (copy/expression block environment (in-package/environment expression)) (copy/quotation (in-package/quotation expression))))) - + (define-method/copy 'PROCEDURE (lambda (block environment procedure) - (with-values + (call-with-values (lambda () (copy/block block environment (procedure/block procedure))) (lambda (block environment) @@ -276,13 +246,15 @@ MIT in each case. |# (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) @@ -299,7 +271,7 @@ MIT in each case. |# (define-method/copy 'QUOTATION (lambda (block environment expression) - block environment ; ignored + block environment ;ignored (copy/quotation expression))) (define-method/copy 'REFERENCE @@ -307,7 +279,7 @@ MIT in each case. |# (reference/make block (copy/variable block environment (reference/variable expression))))) - + (define-method/copy 'SEQUENCE (lambda (block environment expression) (sequence/make @@ -315,5 +287,5 @@ MIT in each case. |# (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 diff --git a/v7/src/sf/emodel.scm b/v7/src/sf/emodel.scm index 8eadea8db..7f0c2fb55 100644 --- a/v7/src/sf/emodel.scm +++ b/v7/src/sf/emodel.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -37,26 +37,179 @@ MIT in each case. |# (declare (usual-integrations) (integrate-external "object")) -(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)))))))))) + +(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)))))))))))))) + (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 diff --git a/v7/src/sf/free.scm b/v7/src/sf/free.scm index 80c5de7b5..01d6a2f3b 100644 --- a/v7/src/sf/free.scm +++ b/v7/src/sf/free.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -35,9 +35,6 @@ MIT in each case. |# ;;;; SCode Optimizer: Free Variable Analysis (declare (usual-integrations) - (automagic-integrations) - (open-block-optimizations) - (eta-substitution) (integrate-external "object" "lsets")) (declare (integrate-operator no-free-variables singleton-variable @@ -114,9 +111,10 @@ MIT in each case. |# (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) @@ -130,7 +128,7 @@ MIT in each case. |# (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) @@ -148,4 +146,4 @@ MIT in each case. |# (define-method/free 'THE-ENVIRONMENT (lambda (expression) expression - (no-free-variables))) + (no-free-variables))) \ No newline at end of file diff --git a/v7/src/sf/make.scm b/v7/src/sf/make.scm index fcd35abdf..f167be6c2 100644 --- a/v7/src/sf/make.scm +++ b/v7/src/sf/make.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -39,4 +39,4 @@ MIT in each case. |# (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 diff --git a/v7/src/sf/object.scm b/v7/src/sf/object.scm index 1250e4c46..79f816c89 100644 --- a/v7/src/sf/object.scm +++ b/v7/src/sf/object.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -35,33 +35,7 @@ MIT in each case. |# ;;;; SCode Optimizer: Data Types ;;; package: (scode-optimizer) -(declare (usual-integrations) - (automagic-integrations) - (open-block-optimizations)) - -(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)) ;;;; Enumerations @@ -96,40 +70,57 @@ MIT in each case. |# (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))) - -;;;; 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))) + +;;;; 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) @@ -140,63 +131,59 @@ MIT in each case. |# 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)) + +;;;; 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]")) - -;;;; 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))) @@ -214,49 +201,29 @@ MIT in each case. |# ;; Useful for debugging (vector-ref dispatch-vector (enumeration/name->index enumeration/expression name))) - -(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 diff --git a/v7/src/sf/pardec.scm b/v7/src/sf/pardec.scm index 6d5aef600..cac164a50 100644 --- a/v7/src/sf/pardec.scm +++ b/v7/src/sf/pardec.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -36,403 +36,366 @@ MIT in each case. |# ;;; package: (scode-optimizer declarations) (declare (usual-integrations) - (open-block-optimizations) - (automagic-integrations) - (eta-substitution) (integrate-external "object")) -(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)) + +;;;; 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)) - -;; before-bindings? should be true if binding 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))))) -(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)))) -;;;; 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)))) - -#| -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)))))))))) -;;; 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)) - -;;;; 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))))))) + '())) -;;;; 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 diff --git a/v7/src/sf/reduct.scm b/v7/src/sf/reduct.scm index 029fc708a..4f829cb6e 100644 --- a/v7/src/sf/reduct.scm +++ b/v7/src/sf/reduct.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -53,7 +53,7 @@ that act differently depending on the number of arguments. (replace-operator ( ( ) ( ) ...)) is a symbol - is a non-negative integer or one of the symbols ANY, ELSE, and OTHERWISE. + is a non-negative integer or one of the symbols ANY, ELSE, OTHERWISE. is a simple expression: ; means a variable (QUOTE ) = ' ; means a constant @@ -224,17 +224,9 @@ Examples: (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 '())) @@ -512,7 +504,7 @@ Examples: ;;;; Replacement top level (define (replacement/make replacement decl-block) - (with-values + (call-with-values (lambda () (parse-replacement (car replacement) (cdr replacement) @@ -525,7 +517,9 @@ Examples: 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))) diff --git a/v7/src/sf/sf.pkg b/v7/src/sf/sf.pkg index a8e43be5b..9a4801ec5 100644 --- a/v7/src/sf/sf.pkg +++ b/v7/src/sf/sf.pkg @@ -1,6 +1,6 @@ #| -*-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 @@ -60,19 +60,17 @@ MIT in each case. |# (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 @@ -123,14 +121,12 @@ MIT in each case. |# (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) @@ -150,7 +146,8 @@ MIT in each case. |# (files "chtype") (parent (scode-optimizer)) (export (scode-optimizer) - intern-type)) + change-type/block + change-type/expression)) (define-package (scode-optimizer build-utilities) (files "butils") diff --git a/v7/src/sf/subst.scm b/v7/src/sf/subst.scm index 9e7c30d6f..79a73dda3 100644 --- a/v7/src/sf/subst.scm +++ b/v7/src/sf/subst.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -36,8 +36,6 @@ MIT in each case. |# ;;; package: (scode-optimizer integrate) (declare (usual-integrations) - (eta-substitution) - (open-block-optimizations) (integrate-external "object" "lsets")) (define *top-level-block*) @@ -52,42 +50,24 @@ MIT in each case. |# (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) @@ -175,8 +155,7 @@ MIT in each case. |# (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) @@ -197,20 +176,20 @@ MIT in each case. |# (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))))))))) (define (integrate/reference-operator operations environment operator operands) (let ((variable (reference/variable operator))) @@ -258,21 +237,50 @@ MIT in each case. |# ;;;; 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) @@ -298,30 +306,6 @@ MIT in each case. |# (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)))) (define (variable/unreferenced? variable) (and (not (variable/integrated variable)) @@ -363,19 +347,24 @@ you ask for. (define *eta-substitution-switch #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) @@ -406,13 +395,14 @@ you ask for. 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))))))) (define-method/integrate 'COMBINATION @@ -465,14 +455,13 @@ you ask for. (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))))) ;;;; Easy Cases @@ -611,7 +600,7 @@ you ask for. (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))) @@ -660,21 +649,18 @@ you ask for. (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))))) @@ -1364,8 +1350,7 @@ forms are simply removed. 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 @@ -1377,8 +1362,7 @@ forms are simply removed. 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 diff --git a/v7/src/sf/tables.scm b/v7/src/sf/tables.scm index 1adb712d9..0b639931e 100644 --- a/v7/src/sf/tables.scm +++ b/v7/src/sf/tables.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -43,15 +43,15 @@ MIT in each case. |# (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) @@ -59,32 +59,22 @@ MIT in each case. |# 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 diff --git a/v7/src/sf/toplev.scm b/v7/src/sf/toplev.scm index 8ee7c01a0..7283ab760 100644 --- a/v7/src/sf/toplev.scm +++ b/v7/src/sf/toplev.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -54,16 +54,8 @@ MIT in each case. |# (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)) @@ -140,27 +132,22 @@ Currently only the 68000 implementation needs this." ;;;; 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)))))) @@ -169,176 +156,153 @@ Currently only the 68000 implementation needs this." (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))) (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)) (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) ;;;; 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))) @@ -371,13 +335,13 @@ Currently only the 68000 implementation needs this." (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) @@ -387,19 +351,20 @@ Currently only the 68000 implementation needs this." (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) diff --git a/v7/src/sf/usiexp.scm b/v7/src/sf/usiexp.scm index f51929da2..dbe8e61d9 100644 --- a/v7/src/sf/usiexp.scm +++ b/v7/src/sf/usiexp.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -36,9 +36,6 @@ MIT in each case. |# ;;; package: (scode-optimizer expansion) (declare (usual-integrations) - (automagic-integrations) - (open-block-optimizations) - (eta-substitution) (integrate-external "object")) ;;;; Fixed-arity arithmetic primitives @@ -287,28 +284,24 @@ MIT in each case. |# (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) diff --git a/v7/src/sf/xform.scm b/v7/src/sf/xform.scm index 9994deb42..76853eb5f 100644 --- a/v7/src/sf/xform.scm +++ b/v7/src/sf/xform.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -35,57 +35,43 @@ MIT in each case. |# ;;;; SCode Optimizer: Transform Input Expression (declare (usual-integrations) - (eta-substitution) - (automagic-integrations) - (open-block-optimizations) (integrate-external "object")) -;;; 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) @@ -101,13 +87,12 @@ MIT in each case. |# (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 @@ -116,58 +101,65 @@ MIT in each case. |# variables)) (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 @@ -176,18 +168,18 @@ MIT in each case. |# (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 @@ -205,36 +197,16 @@ MIT in each case. |# (transform/expression block environment body)) (transform/open-block block environment expression)))) (transform/expression block environment expression))) - -#| -;; 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 @@ -280,15 +252,6 @@ MIT in each case. |# (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) @@ -300,13 +263,13 @@ MIT in each case. |# (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)))) - + (define (transform/the-environment block environment expression) environment expression ; ignored (block/unsafe! block) @@ -324,7 +287,6 @@ MIT in each case. |# (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) diff --git a/v8/src/sf/make.scm b/v8/src/sf/make.scm index fcd35abdf..f167be6c2 100644 --- a/v8/src/sf/make.scm +++ b/v8/src/sf/make.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -39,4 +39,4 @@ MIT in each case. |# (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 diff --git a/v8/src/sf/toplev.scm b/v8/src/sf/toplev.scm index 8ee7c01a0..7283ab760 100644 --- a/v8/src/sf/toplev.scm +++ b/v8/src/sf/toplev.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -54,16 +54,8 @@ MIT in each case. |# (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)) @@ -140,27 +132,22 @@ Currently only the 68000 implementation needs this." ;;;; 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)))))) @@ -169,176 +156,153 @@ Currently only the 68000 implementation needs this." (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))) (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)) (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) ;;;; 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))) @@ -371,13 +335,13 @@ Currently only the 68000 implementation needs this." (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) @@ -387,19 +351,20 @@ Currently only the 68000 implementation needs this." (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) -- 2.25.1