From: Chris Hanson Date: Fri, 5 Oct 1990 11:36:32 +0000 (+0000) Subject: Use one ".free" file to cache data for entire package model. Compress X-Git-Tag: 20090517-FFI~11148 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8b091202d422a03b32213242d65fca4e993f667c;p=mit-scheme.git Use one ".free" file to cache data for entire package model. Compress the data stored in this file by eliminating duplicates and using vectors instead of lists. --- diff --git a/v7/src/cref/anfile.scm b/v7/src/cref/anfile.scm index d7411b531..ae5dc5c4b 100644 --- a/v7/src/cref/anfile.scm +++ b/v7/src/cref/anfile.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/anfile.scm,v 1.3 1989/08/06 07:52:22 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/anfile.scm,v 1.4 1990/10/05 11:36:32 cph Rel $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -36,49 +36,18 @@ MIT in each case. |# (declare (usual-integrations)) -(define (analyze/directory filename) - (for-each - (lambda (input-pathname) - (let ((output-pathname (pathname-new-type input-pathname "free"))) - (if (not (compare-file-modification-times input-pathname - output-pathname)) - (analyze/file input-pathname output-pathname)))) - (directory-read - (merge-pathnames (pathname-as-directory (->pathname filename)) - (string->pathname "*.bin"))))) - -(define (read-analyzed-file input-pathname) - (let ((output-pathname (pathname-new-type input-pathname "free"))) - (if (compare-file-modification-times input-pathname output-pathname) - (fasload output-pathname) - (analyze/file input-pathname output-pathname)))) - -(define (analyze/file input-pathname output-pathname) - (let ((analyzed-file (analyze/top-level (fasload input-pathname)))) - (if analyze/file/memoize? - (fasdump analyzed-file output-pathname)) - analyzed-file)) - -(define analyze/file/memoize? true) - -(define (compare-file-modification-times x y) - (let ((x (file-modification-time x))) - (and x - (let ((y (file-modification-time y))) - (and y - (< x y)))))) - +(define (analyze-file pathname) + (analyze/top-level (fasload pathname))) + (define (analyze/top-level expression) (with-values (lambda () (sort-expressions (process-top-level expression))) (lambda (definitions others) (let ((definition-analysis (map analyze/top-level/definition definitions))) (if (not (null? others)) - (cons (with-values (lambda () - (analyze/expression (make-sequence others))) - (lambda (references assignments executions) - (vector false references assignments executions - 'EXPRESSION))) + (cons (vector false + 'EXPRESSION + (analyze-and-compress (make-sequence others))) definition-analysis) definition-analysis))))) @@ -106,29 +75,30 @@ MIT in each case. |# (let ((name (definition-name definition)) (expression (definition-value definition))) (cond ((unassigned-reference-trap? expression) - (vector name '() '() '() 'UNASSIGNED)) + (vector name 'UNASSIGNED '#())) ((scode-constant? expression) - (vector name '() '() '() 'CONSTANT)) + (vector name 'CONSTANT '#())) (else - (with-values (lambda () (analyze/expression expression)) - (lambda (references assignments executions) - (vector name references assignments executions - (cond ((lambda? expression) 'LAMBDA) - ((delay? expression) 'DELAY) - (else 'EXPRESSION))))))))) + (vector name + (cond ((lambda? expression) 'LAMBDA) + ((delay? expression) 'DELAY) + (else 'EXPRESSION)) + (analyze-and-compress expression)))))) + +(define (analyze-and-compress expression) + (list->vector (analyze/expression expression))) (define (analyze/expression expression) ((scode-walk analyze/dispatch expression) expression)) (define (analyze/expressions expressions) (if (null? expressions) - (values '() '() '()) - (result-sum (lambda () (analyze/expression (car expressions))) - (lambda () (analyze/expressions (cdr expressions)))))) + '() + (eq-set-union (analyze/expression (car expressions)) + (analyze/expressions (cdr expressions))))) (define (analyze/uninteresting expression) - (values (if (primitive-procedure? expression) (list expression) '()) - '() '())) + (if (primitive-procedure? expression) (list expression) '())) (define (analyze/error expression) (error "Illegal expression" expression)) @@ -136,46 +106,28 @@ MIT in each case. |# (define (analyze/access expression) (if (access-environment expression) (warn "Access to non-global environment:" (unsyntax expression))) - (values (list expression) '() '())) + (list expression)) (define (analyze/variable expression) - (values (list (variable-name expression)) '() '())) + (list (variable-name expression))) (define (analyze/assignment expression) - (with-values (lambda () (analyze/expression (assignment-value expression))) - (lambda (references assignments executions) - (values references - (cons (assignment-name expression) assignments) - executions)))) + (eq-set-adjoin (assignment-name expression) + (analyze/expression (assignment-value expression)))) (define (analyze/combination expression) - (result-sum (lambda () - (let ((operator (combination-operator expression))) - (cond ((variable? operator) - (values '() '() (list (variable-name operator)))) - ((or (primitive-procedure? operator) - (and (access? operator) - (not (access-environment operator)))) - (values '() '() (list operator))) - (else - (analyze/expression operator))))) - (lambda () - (analyze/expressions (combination-operands expression))))) + (eq-set-union (analyze/expression (combination-operator expression)) + (analyze/expressions (combination-operands expression)))) (define (analyze/lambda expression) (lambda-components expression (lambda (name required optional rest auxiliary declarations body) name declarations - (with-values (lambda () (analyze/expression body)) - (lambda (references assignments executions) - (let ((bound - (append required - optional - (if rest (list rest) '()) - auxiliary))) - (values (multiset-difference references bound) - (multiset-difference assignments bound) - (multiset-difference executions bound)))))))) + (eq-set-difference (analyze/expression body) + (append required + optional + (if rest (list rest) '()) + auxiliary))))) (define (analyze/error-combination expression) (combination-components expression @@ -214,11 +166,24 @@ MIT in each case. |# (SEQUENCE ,analyze/sequence) (VARIABLE ,analyze/variable)))) -(define (result-sum first rest) - (with-values first - (lambda (references assignments executions) - (with-values rest - (lambda (references* assignments* executions*) - (values (append! references references*) - (append! assignments assignments*) - (append! executions executions*))))))) \ No newline at end of file +(define (eq-set-adjoin x y) + (if (memq x y) + y + (cons x y))) + +(define (eq-set-union x y) + (if (null? y) + x + (let loop ((x x) (y y)) + (if (null? x) + y + (loop (cdr x) + (if (memq (car x) y) + y + (cons (car x) y))))))) + +(define (eq-set-difference x y) + (let loop ((x x)) + (cond ((null? x) '()) + ((memq (car x) y) (loop (cdr x))) + (else (cons (car x) (loop (cdr x))))))) \ No newline at end of file diff --git a/v7/src/cref/cref.pkg b/v7/src/cref/cref.pkg index 7b0813bc1..9e402978b 100644 --- a/v7/src/cref/cref.pkg +++ b/v7/src/cref/cref.pkg @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/cref.pkg,v 1.2 1988/10/28 07:03:12 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/cref.pkg,v 1.3 1990/10/05 11:31:38 cph Rel $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -61,8 +61,7 @@ MIT in each case. |# (files "anfile") (parent (cross-reference)) (export (cross-reference) - analyze/directory - read-analyzed-file)) + analyze-file)) (define-package (cross-reference constructor) (files "conpkg") diff --git a/v7/src/cref/make.scm b/v7/src/cref/make.scm index 79856deee..ee63d8cfe 100644 --- a/v7/src/cref/make.scm +++ b/v7/src/cref/make.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/make.scm,v 1.5 1989/08/03 23:26:06 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/make.scm,v 1.6 1990/10/05 11:34:55 cph Rel $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -37,4 +37,4 @@ MIT in each case. |# (declare (usual-integrations)) (package/system-loader "cref" '() false) -(add-system! (make-system "CREF" 1 5 '())) \ No newline at end of file +(add-system! (make-system "CREF" 1 6 '())) \ No newline at end of file diff --git a/v7/src/cref/redpkg.scm b/v7/src/cref/redpkg.scm index 79e62c576..c121838d0 100644 --- a/v7/src/cref/redpkg.scm +++ b/v7/src/cref/redpkg.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/redpkg.scm,v 1.2 1988/10/28 07:03:24 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/redpkg.scm,v 1.3 1990/10/05 11:33:16 cph Rel $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -38,16 +38,15 @@ MIT in each case. |# (integrate-external "object")) (define (read-package-model filename) - (let* ((pathname (pathname->absolute-pathname (->pathname filename))) - (default-pathname (pathname-directory-path pathname))) + (let ((model-pathname (pathname->absolute-pathname (->pathname filename)))) (with-values (lambda () (sort-descriptions (map (lambda (expression) (parse-package-expression expression)) - (read-package-description-file pathname)))) + (read-package-description-file model-pathname)))) (lambda (packages globals) - (let ((pmodel (descriptions->pmodel packages default-pathname))) + (let ((pmodel (descriptions->pmodel packages model-pathname))) (for-each (let ((root-package (pmodel/root-package pmodel))) (lambda (pathname) @@ -59,7 +58,7 @@ MIT in each case. |# (bind! root-package name expression))) (fasload (merge-pathnames (pathname-new-type pathname "glob") - default-pathname))))) + model-pathname))))) globals) pmodel))))) @@ -86,47 +85,96 @@ MIT in each case. |# (read-file (pathname-default-type pathname "pkg"))) (define (read-file-analyses! pmodel) - (for-each (lambda (package) - (for-each (lambda (pathname) - (read-file-analysis! pmodel package pathname)) - (package/files package))) - (pmodel/packages pmodel))) - -(define (read-file-analysis! pmodel package pathname) - (let ((filename (pathname->string pathname)) - (root-package (pmodel/root-package pmodel)) - (primitive-package (pmodel/primitive-package pmodel))) - (for-each (lambda (entry) - (let ((name (vector-ref entry 0)) - (expression - (make-expression package - filename - (vector-ref entry 4)))) - (let ((intern! - (lambda (name) - (cond ((symbol? name) - (make-reference package name expression)) - ((primitive-procedure? name) - (make-reference - primitive-package - (primitive-procedure-name name) - expression)) - ((access? name) - (if (access-environment name) - (error "Non-root access" name)) - (make-reference root-package - (access-name name) - expression)) - (else - (error "Illegal reference name" name)))))) - (for-each intern! (vector-ref entry 1)) - (for-each intern! (vector-ref entry 2)) - (for-each intern! (vector-ref entry 3))) - (if name - (bind! package name expression)))) - (read-analyzed-file - (merge-pathnames (pathname-new-type pathname "bin") - (pmodel/default-pathname pmodel)))))) + (for-each (lambda (p&c) + (record-file-analysis! pmodel + (car p&c) + (analysis-cache/pathname (cdr p&c)) + (analysis-cache/data (cdr p&c)))) + (cache-file-analyses! pmodel))) + +(define-structure (analysis-cache + (type vector) + (constructor make-analysis-cache (pathname time data)) + (conc-name analysis-cache/)) + (pathname false read-only true) + (time false) + (data false)) + +(define (cache-file-analyses! pmodel) + (let ((pathname (pathname-new-type (pmodel/pathname pmodel) "free"))) + (let ((result + (let ((caches (if (file-exists? pathname) (fasload pathname) '()))) + (append-map! (lambda (package) + (map (lambda (pathname) + (cons package + (cache-file-analysis! pmodel + caches + pathname))) + (package/files package))) + (pmodel/packages pmodel))))) + (fasdump (map cdr result) pathname) + result))) + +(define (cache-file-analysis! pmodel caches pathname) + (let ((cache (analysis-cache/lookup caches pathname)) + (full-pathname + (merge-pathnames (pathname-new-type pathname "bin") + (pmodel/pathname pmodel)))) + (let ((time (file-modification-time full-pathname))) + (if (not time) + (error "unable to open file" full-pathname)) + (if cache + (begin + (if (> time (analysis-cache/time cache)) + (begin + (set-analysis-cache/data! cache (analyze-file full-pathname)) + (set-analysis-cache/time! cache time))) + cache) + (make-analysis-cache pathname time (analyze-file full-pathname)))))) + +(define (analysis-cache/lookup caches pathname) + (let loop ((caches caches)) + (and (not (null? caches)) + (if (pathname=? pathname (analysis-cache/pathname (car caches))) + (car caches) + (loop (cdr caches)))))) + +(define (pathname=? x y) + (and (equal? (pathname-name x) (pathname-name y)) + (equal? (pathname-directory x) (pathname-directory y)) + (equal? (pathname-type x) (pathname-type y)) + (equal? (pathname-version x) (pathname-version y)) + (equal? (pathname-host x) (pathname-host y)) + (equal? (pathname-device x) (pathname-device y)))) + +(define (record-file-analysis! pmodel package pathname entries) + (for-each + (let ((filename (pathname->string pathname)) + (root-package (pmodel/root-package pmodel)) + (primitive-package (pmodel/primitive-package pmodel))) + (lambda (entry) + (let ((name (vector-ref entry 0)) + (expression + (make-expression package filename (vector-ref entry 1)))) + (for-each-vector-element (vector-ref entry 2) + (lambda (name) + (cond ((symbol? name) + (make-reference package name expression)) + ((primitive-procedure? name) + (make-reference primitive-package + (primitive-procedure-name name) + expression)) + ((access? name) + (if (access-environment name) + (error "Non-root access" name)) + (make-reference root-package + (access-name name) + expression)) + (else + (error "Illegal reference name" name))))) + (if name + (bind! package name expression))))) + entries)) (define (resolve-references! pmodel) (for-each (lambda (package) @@ -271,7 +319,7 @@ MIT in each case. |# (lambda (package) (symbol-list=? name (package/name package))))) -(define (descriptions->pmodel descriptions default-pathname) +(define (descriptions->pmodel descriptions pathname) (let ((packages (map (lambda (description) (make-package @@ -322,7 +370,7 @@ MIT in each case. |# (make-package primitive-package-name '() '() false) packages extra-packages - default-pathname)))) + pathname)))) (define primitive-package-name (list (string->symbol "#[(cross-reference reader)primitives]")))