From 9529eb81a2111f46bb5101486b26c9b9755a67ab Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Mon, 14 Mar 1988 20:25:13 +0000 Subject: [PATCH] Change the representation of compiled procedures and other entries: They are now just the address of an instruction with a gc offset preceding the instruction and an arity/type word preceding that. Compiled closures are done by creating a tiny fake compiled code block which jumps to the right place and sets up the free variables for reference. Uuo style links are now just jump instructions to the correct address. All relocators have been updated to reflect this change. Variable caches have no type code. The relocators know about this. New types: TC_COMPILED_ENTRY TC_MANIFEST_CLOSURE TC_LINKAGE_SECTION --- v7/src/compiler/base/lvalue.scm | 12 ++- v7/src/compiler/base/proced.scm | 18 +++- v7/src/compiler/base/switch.scm | 3 +- v7/src/compiler/base/toplev.scm | 114 ++++++++++++---------- v7/src/compiler/base/utils.scm | 9 +- v7/src/compiler/machines/bobcat/decls.scm | 21 ++-- 6 files changed, 105 insertions(+), 72 deletions(-) diff --git a/v7/src/compiler/base/lvalue.scm b/v7/src/compiler/base/lvalue.scm index 031029d68..fb551ad54 100644 --- a/v7/src/compiler/base/lvalue.scm +++ b/v7/src/compiler/base/lvalue.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.3 1987/12/31 10:01:42 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.4 1988/03/14 20:24:11 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -198,7 +198,15 @@ MIT in each case. |# (and value (or (rvalue/constant? value) (and (rvalue/procedure? value) - (procedure/open? value)))))) + (procedure/open? value) +#| + ;; For now this is disabled. + ;; We need self-consistent closing + (or (procedure/open? value) + (and (procedure/closure? value) + (procedure/trivial-closure? value))) +|# + ))))) (define (lvalue=? lvalue lvalue*) (or (eq? lvalue lvalue*) diff --git a/v7/src/compiler/base/proced.scm b/v7/src/compiler/base/proced.scm index fe22ebb46..a678e36d9 100644 --- a/v7/src/compiler/base/proced.scm +++ b/v7/src/compiler/base/proced.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.2 1987/12/30 06:59:17 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.3 1988/03/14 20:24:24 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -56,6 +56,7 @@ MIT in each case. |# closure-block ;for closure, where procedure is closed [block] closure-offset ;for closure, offset of procedure in stack frame register ;for continuation, argument register + closure-size ;for closure, virtual size of frame [integer or false] ) (define *procedures*) @@ -69,7 +70,7 @@ MIT in each case. |# (node->edge (cfg-entry-node scfg)) (list-copy required) (list-copy optional) rest (generate-label name) false false false false false - false))) + false false))) (set! *procedures* (cons procedure *procedures*)) (set-block-procedure! block procedure) procedure)) @@ -130,9 +131,10 @@ MIT in each case. |# (procedure-closing-block procedure)))) (define-integrable (closure-procedure-needs-operator? procedure) - ;; **** When implemented, this must be true if the closure needs its - ;; parent frame since the parent frame is stored in the operator. - true) + ;; This must be true if the closure needs its parent frame since the + ;; parent frame is found from the operator. Currently only avoided + ;; for trivial closures. + (not (procedure/trivial-closure? procedure))) (define (procedure-interface-optimizible? procedure) (and (stack-block? (procedure-block procedure)) @@ -191,6 +193,12 @@ MIT in each case. |# (define-integrable (procedure/closure? procedure) (procedure-closure-block procedure)) +(define-integrable (procedure/trivial-closure? procedure) + (let ((enclosing (procedure-closing-block procedure))) + (or (null? enclosing) + (and (ic-block? enclosing) + (not (ic-block/use-lookup? enclosing)))))) + (define (procedure/closed? procedure) (or (procedure/ic? procedure) (procedure/closure? procedure))) diff --git a/v7/src/compiler/base/switch.scm b/v7/src/compiler/base/switch.scm index ee74ea77b..efcb45d00 100644 --- a/v7/src/compiler/base/switch.scm +++ b/v7/src/compiler/base/switch.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.2 1987/12/30 06:59:45 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.3 1988/03/14 20:24:41 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -41,6 +41,7 @@ MIT in each case. |# (define compiler:show-subphases? false) (define compiler:preserve-data-structures? false) (define compiler:code-compression? true) +(define compiler:compile-once-only-packages-recursively? true) (define compiler:cache-free-variables? true) (define compiler:implicit-self-static? false) (define compiler:cse? true) diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm index 9ee968d36..cde93c1e4 100644 --- a/v7/src/compiler/base/toplev.scm +++ b/v7/src/compiler/base/toplev.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.4 1988/02/19 20:56:49 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.5 1988/03/14 20:24:54 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -159,65 +159,76 @@ MIT in each case. |# (and compiler:generate-rtl-files? (pathname-new-type output-pathname "brtl")) (pathname-new-type output-pathname "binf"))))) + +;;;; Utilities for compiling in batch mode + +(define compiler:batch-mode? false) +(define compiler:abort-handled? false) +(define compiler:abort-continuation) (define (compiler:batch-compile input #!optional output) - (fluid-let (((access *error-hook* error-system) + (fluid-let ((compiler:batch-mode? true) + ((access *error-hook* error-system) (lambda (env mesg irr subst?) - (newline) - (display "*** Error: ") - (display mesg) - (display " ***") - (newline) - (display "Irritant: ") - (write irr) - (compiler:abort false)))) + (if compiler:abort-handled? + (begin + (newline) + (newline) + (display "*** Error: ") + (display mesg) + (display " ***") + (newline) + (display "Irritant: ") + (write irr) + (compiler:abort false)) + ((access standard-error-hook error-system) + env mesg irr subst?))))) (if (unassigned? output) (compile-bin-file input) (compile-bin-file input output)))) - -;;; Utilities for compiling in batch mode - -(define compiler:abort-handled? false) -(define compiler:abort-continuation) (define (compiler:abort value) (if compiler:abort-handled? (begin (newline) - (newline) - (display " Aborting...") + (display "*** Aborting...") (compiler:abort-continuation value)) (error "compiler:abort: Not set up to abort" value))) -(define (compiler-process transform input-pathname output-pathname) - (call-with-current-continuation - (lambda (abort-compilation) - (fluid-let ((compiler:abort-continuation abort-compilation) - (compiler:abort-handled? true)) - (fasdump (transform input-pathname output-pathname) - output-pathname))))) +(define (batch-kernel real-kernel) + (lambda (input-string) + (call-with-current-continuation + (lambda (abort-compilation) + (fluid-let ((compiler:abort-continuation abort-compilation) + (compiler:abort-handled? true)) + (real-kernel input-string)))))) (define (compiler-pathnames input-string output-string default transform) - (let ((kernel - (lambda (input-string) - (let ((input-pathname - (pathname->input-truename - (merge-pathnames (->pathname input-string) default)))) - (if (not input-pathname) - (error "File does not exist" input-string)) - (let ((output-pathname - (let ((output-pathname - (pathname-new-type input-pathname "com"))) - (if output-string - (merge-pathnames (->pathname output-string) - output-pathname) - output-pathname)))) - (newline) - (write-string "Compile File: ") - (write (pathname->string input-pathname)) - (write-string " => ") - (write (pathname->string output-pathname)) - (compiler-process transform input-pathname output-pathname)))))) + (let* ((core + (lambda (input-string) + (let ((input-pathname + (pathname->input-truename + (merge-pathnames (->pathname input-string) default)))) + (if (not input-pathname) + (error "File does not exist" input-string)) + (let ((output-pathname + (let ((output-pathname + (pathname-new-type input-pathname "com"))) + (if output-string + (merge-pathnames (->pathname output-string) + output-pathname) + output-pathname)))) + (newline) + (write-string "Compile File: ") + (write (pathname->string input-pathname)) + (write-string " => ") + (write (pathname->string output-pathname)) + (fasdump (transform input-pathname output-pathname) + output-pathname))))) + (kernel + (if compiler:batch-mode? + (batch-kernel core) + core))) (if (pair? input-string) (for-each kernel input-string) (kernel input-string)))) @@ -567,12 +578,13 @@ MIT in each case. |# (compiler-phase "Linearizing BITs" (lambda () (set! compiler:bits - (LAP ,@(lap:make-entry-point compiler:entry-label - compiler:block-label) - ,@((access linearize-bits lap-syntax-package) - (if compiler:preserve-data-structures? - *rtl-graphs* - (set! *rtl-graphs*)))))))) + (append-instruction-sequences! + (lap:make-entry-point compiler:entry-label + compiler:block-label) + ((access linearize-bits lap-syntax-package) + (if compiler:preserve-data-structures? + *rtl-graphs* + (set! *rtl-graphs*)))))))) (define (phase/assemble) (compiler-phase "Assembling" @@ -622,7 +634,7 @@ MIT in each case. |# (with-interrupt-mask interrupt-mask-none (lambda (old) ((ucode-primitive &make-object) - type-code:compiled-expression + type-code:compiled-entry (make-non-pointer-object (+ (cdr (or (assq label compiler:label-bindings) (error "Missing entry point" label))) diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm index 190190f6f..f2eab1fb6 100644 --- a/v7/src/compiler/base/utils.scm +++ b/v7/src/compiler/base/utils.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.2 1987/12/30 06:56:48 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.3 1988/03/14 20:25:13 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -203,13 +203,10 @@ MIT in each case. |# (define-type-code procedure) (define-type-code extended-procedure) (define-type-code cell) - (define-type-code compiled-expression) - (define-type-code compiler-link) - (define-type-code compiled-procedure) (define-type-code environment) + (define-type-code unassigned) (define-type-code stack-environment) - (define-type-code return-address compiler-return-address) - (define-type-code unassigned)) + (define-type-code compiled-entry)) (define (scode/procedure-type-code *lambda) (cond ((primitive-type? type-code:lambda *lambda) diff --git a/v7/src/compiler/machines/bobcat/decls.scm b/v7/src/compiler/machines/bobcat/decls.scm index eb6ed01bd..1e5f39400 100644 --- a/v7/src/compiler/machines/bobcat/decls.scm +++ b/v7/src/compiler/machines/bobcat/decls.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.2 1988/01/06 18:30:09 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.3 1988/03/14 20:23:52 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -48,12 +48,19 @@ MIT in each case. |# (rank false)) (define source-filenames - (mapcan (lambda (subdirectory) - (map (lambda (pathname) - (string-append subdirectory "/" (pathname-name pathname))) - (directory-read (string-append subdirectory "/*.bin")))) - '("back" "base" "fggen" "fgopt" "rtlbase" "rtlgen" "rtlopt" - "machines/bobcat"))) + (let ((load-env (the-environment))) + (mapcan (lambda (subdirectory) + (map (lambda (pathname) + (string-append subdirectory "/" (pathname-name pathname))) + (directory-read + (string-append + subdirectory + (if (lexical-unbound? load-env + 'SOURCE-FILE-EXPRESSION) + "/*.bin" + source-file-expression))))) + '("back" "base" "fggen" "fgopt" "rtlbase" "rtlgen" "rtlopt" + "machines/bobcat")))) (define source-hash (make/hash-table 101 -- 2.25.1