#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.3 1988/04/06 17:31:26 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.4 1988/04/15 02:08:15 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(lambda ()
(with-output-to-file (pathname-new-type pathname "rtl")
(lambda ()
- (for-each show-rtl-instruction
- (fasload (pathname-new-type pathname "brtl")))))))))
+ (let ((obj (fasload (pathname-new-type pathname "brtl"))))
+ (if (vector? obj)
+ (for-each (lambda (block)
+ (write-char #\page)
+ (newline)
+ (write-string "Disassembly for object ")
+ (write (car block))
+ (for-each show-rtl-instruction (cdr block))
+ (newline))
+ (vector->list obj))
+ (for-each show-rtl-instruction obj)))))))))
(define (dump-rtl filename)
(write-instructions
-(declare (usual-integrations))
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/infnew.scm,v 4.2 1988/04/15 02:08:43 jinx Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Debugging information output.
+
+(declare (usual-integrations))
+\f
(define (generation-phase2 label-bindings external-labels)
(make-compiler-info
'()
(else (loop (cdr external-labels)))))))
label-bindings)
(lambda (x y)
- (< (label-info-offset x) (label-info-offset y)))))))
\ No newline at end of file
+ (< (label-info-offset x) (label-info-offset y)))))))
+
+(define (generate-vector top-level selector others)
+ (let* ((last (length others))
+ (v (make-vector (1+ last) '())))
+ (vector-set! v 0 top-level)
+ (let loop ((l others))
+ (if (null? l)
+ v
+ (let ((desc (car l)))
+ (vector-set! v (car desc) (selector desc))
+ (loop (cdr l)))))))
+
+(define (generate-top-level-info top-level others)
+ (if (null? others)
+ top-level
+ (generate-vector top-level cadr others)))
+
+(define (generate-top-level-object top-level others)
+ (if (null? others)
+ top-level
+ (scode/make-comment
+ (list compiler-entries-tag
+ (generate-vector (compiled-code-address->block top-level)
+ caddr others))
+ top-level)))
\ No newline at end of file
#| -*-Scheme-*-
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.5 1988/04/15 02:09:04 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define-integrable (variable-assigned! variable)
(set-variable-assigned?! variable true))
+;; Note:
+;; If integration of known block values (first class environments) is
+;; ever done, the package "optimization" transformations in
+;; fggen/canon and fggen/fggen may break. There is a hidden reference
+;; to the environment variable from lambda expressions closed in that
+;; context. The variable can be eliminated if there are no references
+;; and there are no lambda expressions implicitely referencing it.
+
(define (lvalue-integrated? lvalue)
(let ((value (lvalue-known-value lvalue)))
(and value
#| -*-Scheme-*-
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.4 1988/04/15 02:09:17 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(ic-block? (procedure-block procedure)))
(define-integrable (procedure/closure? procedure)
- (procedure-closure-block procedure))
+ (and (procedure-closure-block procedure)
+ (not (procedure/ic? 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))))))
+ (not (ic-block/use-lookup? enclosing))))))
(define (procedure/closed? procedure)
(or (procedure/ic? procedure)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/scode.scm,v 4.2 1987/12/30 06:59:28 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/scode.scm,v 4.3 1988/04/15 02:09:29 jinx Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
make-open-block open-block? open-block-components
primitive-procedure?
make-quotation quotation? quotation-expression
- make-sequence sequence-actions
+ make-sequence sequence-actions sequence-components
symbol?
make-the-environment the-environment?
make-unassigned-object unassigned-object?
(define-integrable (scode/constant-value constant) constant)
(define scode/constant? (access scode-constant? system-global-environment))
+(define-integrable (scode/quotation-components quot recvr)
+ (recvr (scode/quotation-expression quot)))
+
+(define comment-tag:directive (make-named-tag "Expression Directive"))
+
+(define (scode/make-directive directive code)
+ (scode/make-comment (list comment-tag:directive directive)
+ code))
(define (scode/make-let names values . body)
(scan-defines (scode/make-sequence body)
(lambda (auxiliary declarations body)
#| -*-Scheme-*-
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.4 1988/04/15 02:09:42 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
+;;; Binary switches
+
(define compiler:enable-integration-declarations? true)
(define compiler:enable-expansion-declarations? true)
(define compiler:show-subphases? false)
(define compiler:implicit-self-static? false)
(define compiler:cse? true)
(define compiler:open-code-primitives? true)
-(define compiler:generate-rtl-files? false)
\ No newline at end of file
+(define compiler:generate-rtl-files? false)
+
+;;; Nary switches
+
+(define compiler:package-optimization-level
+ ;; Possible values: NONE LOW HYBRID HIGH
+ 'HYBRID)
\ No newline at end of file
#| -*-Scheme-*-
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.6 1988/04/15 02:09:53 jinx Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(declare (usual-integrations))
\f
;;; Global variables
+
+(define *recursive-compilation-count*)
+(define *recursive-compilation-number*)
+(define *recursive-compilation-results*)
+(define *recursive-compilation-rtl-blocks*)
+
+(define *info-output-pathname* false)
+(define *rtl-output-pathname* false)
+
(define *input-scode*)
+(define *scode*)
(define *ic-procedure-headers*)
(define *root-block*)
(define *root-expression*)
(define compiler:real-time 0)
(define (compiler:reset!)
+ (set! *recursive-compilation-number* 0)
+ (set! *recursive-compilation-count* 1)
+ (set! *recursive-compilation-results* '())
+ (set! *recursive-compilation-rtl-blocks* '())
(set! *input-scode*)
+ (set! *scode*)
(set! *current-label-number*)
(set! *constants*)
(set! *blocks*)
(set! compiler:entry-points)
(set! compiler:expression))
\f
-(define (in-compiler thunk)
- (fluid-let ((compiler:process-time 0)
- (compiler:real-time 0)
- #|(*input-scode*)
+(define (in-compiler-recursively thunk)
+ (fluid-let ((*input-scode*)
+ (*scode*)
(*current-label-number*)
(*constants*)
(*blocks*)
(*assignments*)
(*ic-procedure-headers*)
(*root-expression*)
- (*root-block*)
- (*rtl-expression*)
- (*rtl-procedures*)
- (*rtl-continuations*)
- (*rtl-graphs*)
- (label->object)
- (*machine-register-map*)
- (compiler:external-labels)
- (compiler:label-bindings)
- (compiler:block-label)
- (compiler:entry-label)
- (compiler:bits)
- (compiler:code-vector)
- (compiler:entry-points)
- (compiler:expression)|#)
+ (*root-block*))
+ (fluid-let ((*rtl-expression*)
+ (*rtl-procedures*)
+ (*rtl-continuations*)
+ (*rtl-graphs*)
+ (label->object)
+ (*machine-register-map*)
+ (compiler:external-labels)
+ (compiler:label-bindings)
+ (compiler:block-label)
+ (compiler:entry-label)
+ (compiler:bits)
+ (compiler:code-vector)
+ (compiler:entry-points)
+ (compiler:expression))
+ (thunk))))
+
+(define (in-compiler thunk)
+ (fluid-let ((compiler:process-time 0)
+ (compiler:real-time 0))
(compiler:reset!)
- (let ((value (thunk)))
+ (let* ((topl (thunk))
+ (value
+ ((access generate-top-level-object
+ debugging-information-package)
+ topl *recursive-compilation-results*)))
(if (not compiler:preserve-data-structures?)
(compiler:reset!))
(compiler-time-report "Total compilation time"
(scode-eval (compile-scode (procedure-lambda procedure) false false)
(procedure-environment procedure)))
+;; The rtl output should be fixed
+
+(define (compile-recursively scode)
+ (let ((my-number *recursive-compilation-count*))
+ (set! *recursive-compilation-count* (1+ my-number))
+ (newline)
+ (newline)
+ (display " *** Recursive compilation ")
+ (write my-number)
+ (display " ***")
+ (let ((val
+ (fluid-let ((*recursive-compilation-number* my-number)
+ (compiler:package-optimization-level 'NONE))
+ (compile-scode scode
+ (and *rtl-output-pathname* true)
+ (and *info-output-pathname* true)
+ in-compiler-recursively))))
+ (newline)
+ (display " *** Done with recursive compilation ")
+ (write my-number)
+ (display " ***")
+ (newline)
+ val)))
+
(define (compile-scode scode
#!optional
rtl-output-pathname
- info-output-pathname)
+ info-output-pathname
+ wrapper)
(if (unassigned? rtl-output-pathname)
(set! rtl-output-pathname false))
(if (unassigned? info-output-pathname)
(set! info-output-pathname false))
- (in-compiler
- (lambda ()
- (set! *input-scode* scode)
- (phase/fg-generation)
- (phase/fg-optimization)
- (phase/rtl-generation)
-#|
- (if info-output-pathname
- (phase/info-generation-1 info-output-pathname))
-|#
- (phase/rtl-optimization)
- (if rtl-output-pathname
- (phase/rtl-file-output rtl-output-pathname))
- (phase/bit-generation)
- (phase/bit-linearization)
- (phase/assemble)
- (if info-output-pathname
- (phase/info-generation-2 info-output-pathname))
- (phase/link)
- compiler:expression
- )))
+ (fluid-let ((*info-output-pathname*
+ (if (and info-output-pathname
+ (not (eq? info-output-pathname true)))
+ info-output-pathname
+ *info-output-pathname*))
+ (*rtl-output-pathname*
+ (if (and rtl-output-pathname
+ (not (eq? rtl-output-pathname true)))
+ rtl-output-pathname
+ *rtl-output-pathname*)))
+ ((if (unassigned? wrapper)
+ in-compiler
+ wrapper)
+ (lambda ()
+ (set! *input-scode* scode)
+ (phase/fg-generation)
+ (phase/fg-optimization)
+ (phase/rtl-generation)
+ #|
+ (if info-output-pathname
+ (phase/info-generation-1 info-output-pathname))
+ |#
+ (phase/rtl-optimization)
+ (if rtl-output-pathname
+ (phase/rtl-file-output rtl-output-pathname))
+ (phase/bit-generation)
+ (phase/bit-linearization)
+ (phase/assemble)
+ (if info-output-pathname
+ (phase/info-generation-2 info-output-pathname))
+ (phase/link)
+ compiler:expression))))
\f
(define (compiler-phase name thunk)
(compiler-phase/visible name
(SET! ,name)))
\f
(define (phase/fg-generation)
- (compiler-phase "Generating the Flow Graph"
- (lambda ()
- (set! *current-label-number* 0)
- (set! *constants* '())
- (set! *blocks* '())
- (set! *expressions* '())
- (set! *procedures* '())
- (set! *lvalues* '())
- (set! *applications* '())
- (set! *parallels* '())
- (set! *assignments* '())
- (set! *root-expression*
- ((access construct-graph fg-generator-package)
- (if compiler:preserve-data-structures?
- *input-scode*
- (set! *input-scode*))))
- (set! *root-block* (expression-block *root-expression*))
- (if (or (null? *expressions*)
- (not (null? (cdr *expressions*))))
- (error "Multiple expressions"))
- (set! *expressions*))))
+ (compiler-superphase
+ "Generating the Flow Graph"
+ (lambda ()
+ (phase/canonicalize-scode)
+ (phase/translate-scode))))
+
+(define (phase/canonicalize-scode)
+ (compiler-subphase "Canonicalizing Scode"
+ (lambda ()
+ (set! *scode*
+ ((access canonicalize/top-level fg-generator-package)
+ (last-reference *input-scode*))))))
+(define (phase/translate-scode)
+ (compiler-subphase "Translating Scode into Flow Graph"
+ (lambda ()
+ (set! *current-label-number* 0)
+ (set! *constants* '())
+ (set! *blocks* '())
+ (set! *expressions* '())
+ (set! *procedures* '())
+ (set! *lvalues* '())
+ (set! *applications* '())
+ (set! *parallels* '())
+ (set! *assignments* '())
+ (set! *root-expression*
+ ((access construct-graph fg-generator-package)
+ (last-reference *scode*)))
+ (set! *root-block* (expression-block *root-expression*))
+ (if (or (null? *expressions*)
+ (not (null? (cdr *expressions*))))
+ (error "Multiple expressions"))
+ (set! *expressions*))))
+\f
(define (phase/fg-optimization)
(compiler-superphase "Optimizing the Flow Graph"
(lambda ()
(set! *ic-procedure-headers* '())
(initialize-machine-register-map!)
((access generate/top-level rtl-generator-package)
- (if compiler:preserve-data-structures?
- *root-expression*
- (set! *root-expression*)))
+ (last-reference *root-expression*))
(set! label->object
(make/label->object *rtl-expression*
*rtl-procedures*
(define (phase/rtl-file-output pathname)
(compiler-phase "RTL File Output"
(lambda ()
- (fasdump ((access linearize-rtl rtl-generator-package) *rtl-graphs*)
- pathname))))
+ (let ((lin ((access linearize-rtl rtl-generator-package) *rtl-graphs*)))
+ (if (eq? pathname true)
+ ;; recursive compilation
+ (set! *recursive-compilation-rtl-blocks*
+ (cons (cons *recursive-compilation-number* lin)
+ *recursive-compilation-rtl-blocks*))
+ (fasdump (if (null? *recursive-compilation-rtl-blocks*)
+ lin
+ (list->vector
+ (cons (cons 0 lin) *recursive-compilation-rtl-blocks*)))
+ pathname))))))
(define (phase/register-allocation)
(compiler-subphase "Allocating Registers"
(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*))))))))
+ (last-reference *rtl-graphs*)))))))
(define (phase/assemble)
(compiler-phase "Assembling"
phase/assemble-finish)))))
(define (phase/assemble-finish count code-vector labels bindings linkage-info)
+ linkage-info ;; ignored
(set! compiler:code-vector code-vector)
(set! compiler:entry-points labels)
(set! compiler:label-bindings bindings)
(define (phase/info-generation-2 pathname)
(compiler-phase "Generating Debugging Information (pass 2)"
- (lambda ()
- (fasdump ((access generation-phase2 debugging-information-package)
- compiler:label-bindings
- (if compiler:preserve-data-structures?
- compiler:external-labels
- (set! compiler:external-labels)))
- pathname)
- (set-compiled-code-block/debugging-info! compiler:code-vector
- (pathname->string pathname)))))
+ (lambda ()
+ (let ((info
+ ((access generation-phase2 debugging-information-package)
+ compiler:label-bindings
+ (last-reference compiler:external-labels))))
+
+ (if (eq? pathname true) ; recursive compilation
+ (begin
+ (set! *recursive-compilation-results*
+ (cons (list *recursive-compilation-number*
+ info
+ compiler:code-vector)
+ *recursive-compilation-results*))
+ (set-compiled-code-block/debugging-info!
+ compiler:code-vector
+ (cons (pathname->string *info-output-pathname*)
+ *recursive-compilation-number*)))
+ (begin
+ (fasdump ((access generate-top-level-info
+ debugging-information-package)
+ info *recursive-compilation-results*)
+ pathname)
+ (set-compiled-code-block/debugging-info!
+ compiler:code-vector
+ (pathname->string pathname))))))))
\f
(define (phase/link)
(compiler-phase "Linking"
(lambda ()
- ;; This has sections locked against GC since the code may not be
- ;; purified.
+ ;; This has sections locked against GC to prevent relocation
+ ;; while computing addresses.
(let ((bindings
(map (lambda (label)
(cons
label
(with-interrupt-mask interrupt-mask-none
(lambda (old)
+ old ;; ignored
((ucode-primitive &make-object)
type-code:compiled-entry
(make-non-pointer-object
#| -*-Scheme-*-
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.4 1988/04/15 02:10:18 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
within-control-point
call-with-current-continuation
non-reentrant-call-with-current-continuation
- with-threaded-continuation
with-interrupt-mask
with-interrupts-reduced
execute-at-new-state-point
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.4 1988/03/14 20:48:00 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.5 1988/04/15 02:06:34 jinx Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(continue/rvalue-constant block continuation (make-constant expression)))
(define (generate/the-environment block continuation expression)
+ expression ;; ignored
(continue/rvalue-constant block continuation block))
(define (continue/rvalue-constant block continuation rvalue)
rvalue))
(define (continue/predicate-constant block continuation rvalue)
+ block continuation ;; ignored
(if (and (rvalue/constant? rvalue)
(false? (constant-value rvalue)))
(snode->pcfg-false (make-fg-noop))
(make-return block (make-reference block continuation true) rvalue))
(define (continue/effect block continuation rvalue)
+ rvalue ;; ignored
(if (variable? continuation)
(continue/unknown block continuation (make-constant false))
(make-null-cfg)))
(define-integrable (continue/predicate block continuation rvalue)
+ block continuation ;; ignored
(make-true-test rvalue))
(define (continue/value block continuation rvalue)
(search block))
\f
(define (generate/lambda block continuation expression)
- (generate/lambda* block continuation expression false))
+ (generate/lambda* block continuation expression false false))
-(define (generate/lambda* block continuation expression continuation-type)
+(define (generate/lambda* block continuation expression
+ continuation-type closure-block)
(continue/rvalue-constant
block
continuation
(optional (make-variables block optional))
(rest (and rest (make-variable block rest)))
(names (make-variables block names)))
+ (define (kernel)
+ (make-procedure
+ continuation-type/procedure
+ block name (cons continuation required) optional rest names
+ (map
+ (lambda (value)
+ ;; The other parts of this subproblem are not
+ ;; interesting since `value' is guaranteed to
+ ;; be either a constant or a procedure.
+ (subproblem-rvalue
+ (generate/subproblem/value block continuation value)))
+ values)
+ (generate/body block continuation declarations body)))
(set-continuation-variable/type! continuation continuation-type)
(set-block-bound-variables! block
`(,continuation
,@optional
,@(if rest (list rest) '())
,@names))
- (make-procedure
- continuation-type/procedure
- block name (cons continuation required) optional rest names
- (map (lambda (value)
- ;; The other parts of this subproblem are not
- ;; interesting since `value' is guaranteed to
- ;; be either a constant or a procedure.
- (subproblem-rvalue
- (generate/subproblem/value block continuation value)))
- values)
- (generate/body block continuation declarations body))))))))))
+ (if closure-block
+ (let ((proc (kernel)))
+ (set-procedure-closure-block! proc closure-block)
+ proc)
+ (kernel))))))))))
\f
(define (parse-procedure-body auxiliary body)
(transmit-values
lambda-tag:let auxiliary '() false names '()
(scode/make-sequence
(map* actions scode/make-assignment names values)))
- (map (lambda (name) (scode/make-unassigned-object))
+ (map (lambda (name)
+ name ;; ignored
+ (scode/make-unassigned-object))
auxiliary)))))))
(define (parse-procedure-body* names actions)
(generate/lambda* block
continuation*
operator
- (continuation/known-type continuation))
+ (continuation/known-type continuation)
+ false)
(generate/expression block
continuation*
operator)))))
(scode/make-combination (ucode-primitive lexical-reference)
(list environment name))))))
-(define (generate/comment block continuation expression)
- (generate/expression block
- continuation
- (scode/comment-expression expression)))
-
+;; Handle directives inserted by the canonicalizer
+
+(define (generate/comment block continuation comment)
+ (scode/comment-components comment
+ (lambda (text expression)
+ (if (or (not (pair? text))
+ (not (eq? (car text) comment-tag:directive))
+ (null? (cdr text))
+ (not (pair? (cadr text)))) (generate/expression block continuation expression)
+ (case (caadr text)
+ ((PROCESSED)
+ (generate/expression block continuation expression))
+ ((COMPILE)
+ (if (not (scode/quotation? expression))
+ (error "generate/comment: Bad compile directive" comment))
+ (continue/rvalue-constant block continuation
+ (make-constant
+ (compile-recursively (scode/quotation-expression expression))))) ((ENCLOSE)
+ (generate/enclose block continuation expression))
+ (else
+ (warn "generate/comment: Unknown directive" (cadr text) comment)
+ (generate/expression block continuation expression)))))))
+
+;; Enclose directives are generated only for lambda expressions
+;; evaluated in environments whose manipulation has been made
+;; explicit. The code should include a syntatic check. The;; expression must be a call to scode-eval with a quotation of a
+;; lambda and a variable as arguments.
+;; NOTE: This code depends on lvalue-integrated? never integrating
+;; the hidden reference within the procedure object. See base/lvalue
+;; for some more information.
+
+(define (generate/enclose block continuation expression)
+ (scode/combination-components
+ expression
+ (lambda (operator operands)
+ operator ;; ignored
+ (generate/lambda*
+ (block-parent block)
+ continuation
+ (scode/quotation-expression (car operands))
+ false
+ (make-reference block
+ (find-name block
+ (scode/variable-name (cadr operands)))
+ false)))))
+\f
(define (generate/delay block continuation expression)
(generate/combination
block
(scode/make-combination compiled-error-procedure
(cons message irritants))))))
-;; For now
-
-(define (compile-recursively expression block)
- (error "compile-recursively: invoked!" expression))
-
-(define (compile-recursively? block)
- false)
-
(define (generate/in-package block continuation expression)
- (let ((recursive? (compile-recursively? block)))
- (if (not recursive?)
- (warn "dynamic IN-PACKAGE not supported; body will be interpreted"
- expression))
- (scode/in-package-components expression
- (lambda (environment expression)
- (generate/combination
- block
- continuation
- (scode/make-combination
- (ucode-primitive scode-eval)
- (list (if recursive?
- (scode/make-constant
- (compile-recursively expression false))
- (scode/make-quotation expression))
- environment)))))))
+ (warn "generate/in-package: expression will be interpreted"
+ expression)
+ (scode/in-package-components expression
+ (lambda (environment expression)
+ (generate/combination
+ block
+ continuation
+ (scode/make-combination
+ (ucode-primitive scode-eval)
+ (list (scode/make-quotation expression)
+ environment))))))
(define (generate/quotation block continuation expression)
(generate/combination
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.3 1988/03/14 20:51:26 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.4 1988/04/15 02:06:00 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define (close-procedure! block)
(let ((procedure (block-procedure block))
(parent (block-parent block)))
+ ;; Note: this should be innocuous if there is already a closure block.
+ ;; In particular, if there is a closure block which happens to be a
+ ;; reference placed there by the first-class environment transformation
+ ;; in fggen/fggen and fggen/canon, and it is replaced by the line below,
+ ;; the presumpt first-class environment is not really used as one, so
+ ;; the procedure is being "demoted" from first-class to closure.
(set-procedure-closure-block! procedure parent)
(((find-closure-bindings
(lambda (closure-frame-block size)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/closan.scm,v 4.2 1987/12/30 06:44:12 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/closan.scm,v 4.3 1988/04/15 02:05:28 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
of a stack associates procedure extent with block scope. For many
simple techniques it generates more information than is needed.
+**** Unfortunately the analysis is not compatible with the current
+implementation of closures. If a closure invokes another procedure
+which is not a child, the current implementation requires that the
+other procedure also be a closure. However, if the closing-limit of
+the caller is the same as the closure-block of the callee, the callee
+will not be marked as a closure. This has disastrous results. As a
+result, the analysis has been modified to force the closure-limit to
+#F whenever a closure is identified.
+
|#
\f
(package (identify-closure-limits!)
(and procedure
(rvalue/procedure? procedure)
(procedure-always-known-operator? procedure)
- (procedure-block procedure)))))
+ ;; **** Force trivial closure limit.
+ ;; (procedure-block procedure)
+ false))))
(define (close-assignment-values! assignment)
(close-rvalue! (assignment-rvalue assignment)
- (variable-block (assignment-lvalue assignment))))
+ ;; **** Force trivial closure limit.
+ ;; (variable-block (assignment-lvalue assignment))
+ false))
\f
(define-integrable (close-rvalue! rvalue binding-block)
(close-values! (rvalue-values rvalue) binding-block))
(if (not (eq? new-closing-limit closing-limit))
(begin
(set-procedure-closing-limit! procedure new-closing-limit)
- ;; The following line forces the procedure's type to CLOSURE.
- (set-procedure-closure-block! procedure true)
+ (if (not (procedure-closure-block procedure))
+ ;; The following line forces the procedure's type to CLOSURE.
+ (set-procedure-closure-block! procedure true))
(close-callees! (procedure-block procedure) new-closing-limit))))))
(define (close-callees! block new-closing-limit)
#| -*-Scheme-*-
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.4 1988/04/15 02:08:28 jinx Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(filename/append "machines/bobcat"
"insmac" "machin" "rgspcm")
(filename/append "fggen"
- "declar" "fggen")
+ "declar" "fggen" "canon")
(filename/append "fgopt"
"blktyp" "closan" "conect" "contan" "desenv" "folcon"
"offset" "operan" "order" "outer" "simapp" "simple")
(file-dependency/integration/join
(append
(filename/append "fggen"
- "declar" "fggen")
+ "declar" "fggen") ; "canon" needs no integrations
(filename/append "fgopt"
"blktyp" "closan" "conect" "contan" "desenv" "folcon"
"offset" "operan" "order" "outer" "simapp" "simple"))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 4.2 1988/03/14 20:54:09 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 4.3 1988/04/15 02:04:53 jinx Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(recvr (make-non-trivial-closure-cons value)
(rtl:interpreter-call-result:enclose))))
((IC)
- (recvr (make-null-cfg)
- (make-ic-cons value)))
+ (make-ic-cons value 'USE-ENV recvr))
((OPEN-EXTERNAL OPEN-INTERNAL)
(error "Letrec value is open procedure" value))
(else
(find-variable block variable 0
rtl:make-fetch
(lambda (nearest-ic-locative name)
+ nearest-ic-locative name ;; ignored
(error "Missing closure variable" variable))
(lambda (name)
+ name ;; ignored
(error "Missing closure variable" variable)))))
;;; end GENERATE/PROCEDURE-HEADER
d3 1
a4 1
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.4 1988/03/14 20:54:28 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.5 1988/04/15 02:04:18 jinx Exp $
#| -*-Scheme-*-
Copyright (c) 1987 Massachusetts Institute of Technology
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.4 1988/03/14 20:54:28 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.5 1988/04/15 02:04:18 jinx Exp $
Copyright (c) 1988, 1990 Massachusetts Institute of Technology
;;;; RTL Generation: RValues
;;; package: (compiler rtl-generator generate/rvalue)
-(package (generate/rvalue load-closure-environment)
+(package (generate/rvalue load-closure-environment make-ic-cons)
(define-export (generate/rvalue operand offset scfg*cfg->cfg! generator)
(transmit-values (generate/rvalue* operand offset)
\f
result
(lambda (constant offset)
+ offset ;; ignored
(generate/constant constant)))
(define-method-table-entry 'CONSTANT rvalue-methods
(define (generate/constant constant)
(lambda (constant)
(lambda (block offset)
+ block offset ;; ignored
(define-method-table-entry 'BLOCK rvalue-methods
block ;; ignored
(rtl:make-fetch register))))
(rtl:make-fetch register)))))
(else
- (expression-value/simple (make-ic-cons procedure)))
+ (make-ic-cons procedure offset
+ (lambda (scfg expr) (return-2 scfg expr))))
(make-cons-closure-indirection procedure)))))
(error "Reference to open procedure" procedure))
(if (not (procedure-virtual-closure? procedure))
(error "Reference to open procedure" procedure))
;; inside another IC procedure?
(define-export (load-closure-environment procedure offset closure-locative)
+ (define (load-closure-parent block force?)
+ (if (and (not force?)
+ (or (not block)
+ (not (ic-block/use-lookup? block))))
+ (make-null-cfg)
+ (let ((closure-block (procedure-closure-block procedure)))
+ (rtl:make-assignment
+ (rtl:locative-offset closure-locative closure-block-first-offset)
+ (cond ((not (ic-block/use-lookup? block))
+ (rtl:make-constant false))
+ ((reference? closure-block)
+ (error "load-closure-environment: bad closure block"
+ procedure))
+ ((ic-block? closure-block)
+ (rtl:make-fetch register:environment))
+ (else
+ (closure-ic-locative closure-block block offset)))))))
+ (enqueue-procedure! procedure)
(let ((block (procedure-closing-block procedure)))
(define (make-non-trivial-closure-cons procedure block**)
(make-null-cfg))
((ic-block? block)
- (rtl:make-assignment
- (rtl:locative-offset closure-locative closure-block-first-offset)
- (if (ic-block/use-lookup? block)
- (let ((closure-block (procedure-closure-block procedure)))
- (if (ic-block? closure-block)
- (rtl:make-fetch register:environment)
- (closure-ic-locative closure-block block offset)))
- (rtl:make-constant false))))
+ (load-closure-parent block true))
((closure-block? block)
(let ((closure-block (procedure-closure-block procedure)))
(define (loop entries code)
(loop
(block-closure-offsets block)
- (if (let ((parent (block-parent block)))
- (and parent (ic-block/use-lookup? parent)))
- (rtl:make-assignment
- (rtl:locative-offset closure-locative
- closure-block-first-offset)
- (if (ic-block? closure-block)
- (rtl:make-fetch register:environment)
- (closure-ic-locative closure-block block offset)))
- (make-null-cfg)))))
+ (load-closure-parent (block-parent block) false))))
(else
(error "Unknown block type" block)))))
-
-;;; end GENERATE/RVALUE
-)
\f
-(define (make-ic-cons procedure)
+(define-export (make-ic-cons procedure offset recvr)
;; IC procedures have their entry points linked into their headers
;; at load time by the linker.
- (let ((header
- (scode/make-lambda (procedure-name procedure)
- (map variable-name
- (procedure-required-arguments procedure))
- (map variable-name (procedure-optional procedure))
- (let ((rest (procedure-rest procedure)))
- (and rest (variable-name rest)))
- (map variable-name (procedure-names procedure))
- '()
- false)))
+ (let* ((header
+ (scode/make-lambda (procedure-name procedure)
+ (map variable-name
+ (procedure-required-arguments procedure))
+ (map variable-name (procedure-optional procedure))
+ (let ((rest (procedure-rest procedure)))
+ (and rest (variable-name rest)))
+ (map variable-name (procedure-names procedure))
+ '()
+ false))
+ (kernel
+ (lambda (scfg expr)
+ (recvr scfg
+ (rtl:make-typed-cons:pair
+ (rtl:make-constant (scode/procedure-type-code header))
+ (rtl:make-constant header)
+ expr)))))
(set! *ic-procedure-headers*
(cons (cons header (procedure-label procedure))
*ic-procedure-headers*))
- (rtl:make-typed-cons:pair
- (rtl:make-constant (scode/procedure-type-code header))
- (rtl:make-constant header)
- ;; Is this right if the procedure is being closed
- ;; inside another IC procedure?
- (rtl:make-fetch register:environment))))
+
+ (cond ((not (reference? (procedure-closure-block procedure)))
+ ;; Is this right if the procedure is being closed
+ ;; inside another IC procedure?
+ (kernel (make-null-cfg)
+ (rtl:make-fetch register:environment)))
+ ((eq? offset 'USE-ENV)
+ (error "make-ic-cons: offset unavailable" procedure))
+ (else
+ (transmit-values
+ (generate/rvalue* (procedure-closure-block procedure)
+ offset)
+ kernel)))))
+;;; end GENERATE/RVALUE
+)
+\f
(define (make-trivial-closure-cons procedure)
(rtl:make-cons-pointer
(rtl:make-constant type-code:compiled-entry)
projects / mit-scheme.git / commitdiff