#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 4.6 1988/11/07 23:50:50 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 4.7 1989/08/21 19:30:23 cph Exp $
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989 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
-(define *block-start-label*)
(define *current-bblock*)
(define *pending-bblocks*)
-(define (generate-bits rgraphs receiver)
+(define (generate-bits rgraphs remote-links process-constants-block)
(with-new-node-marks
(lambda ()
- (fluid-let ((*next-constant* 0)
- (*interned-constants* '())
- (*interned-variables* '())
- (*interned-assignments* '())
- (*interned-uuo-links* '())
- (*block-start-label* (generate-label)))
- (for-each cgen-rgraph rgraphs)
- (receiver *block-start-label*
- (generate/quotation-header *block-start-label*
- *interned-constants*
- *interned-variables*
- *interned-assignments*
- *interned-uuo-links*))))))
+ (for-each cgen-rgraph rgraphs)
+ (for-each (lambda (remote-link)
+ (vector-set! remote-link
+ 0
+ (constant->label (vector-ref remote-link 0)))
+ unspecific)
+ remote-links)
+ (with-values
+ (lambda ()
+ (generate/constants-block *interned-constants*
+ *interned-variables*
+ *interned-assignments*
+ *interned-uuo-links*))
+ (or process-constants-block
+ (lambda (constants-code environment-label free-ref-label n-sections)
+ (LAP ,@constants-code
+ ,@(if free-ref-label
+ (generate/quotation-header environment-label
+ free-ref-label
+ n-sections)
+ (LAP))
+ ,@(let loop ((remote-links remote-links))
+ (if (null? remote-links)
+ (LAP)
+ (LAP ,@(let ((remote-link (car remote-links)))
+ (if (vector-ref remote-link 2)
+ (generate/remote-link
+ (vector-ref remote-link 0)
+ (vector-ref remote-link 1)
+ (vector-ref remote-link 2)
+ (vector-ref remote-link 3))
+ (LAP)))
+ ,@(loop (cdr remote-links))))))))))))
(define (cgen-rgraph rgraph)
(fluid-let ((*current-rgraph* rgraph)
(rgraph-entry-edges rgraph))
(if (not (null? *pending-bblocks*))
(error "CGEN-RGRAPH: pending blocks left at end of pass"))))
-
+\f
(define (cgen-entry edge)
(define (loop bblock map)
(cgen-bblock bblock map)
(if (sblock? bblock)
(cgen-right (snode-next-edge bblock))
- (begin (cgen-right (pnode-consequent-edge bblock))
- (cgen-right (pnode-alternative-edge bblock)))))
+ (begin
+ (cgen-right (pnode-consequent-edge bblock))
+ (cgen-right (pnode-alternative-edge bblock)))))
+
(define (cgen-right edge)
(let ((next (edge-next-node edge)))
(if (and next (not (node-marked? next)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crsend.scm,v 1.1 1989/05/17 20:44:56 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crsend.scm,v 1.2 1989/08/21 19:32:18 cph Exp $
$MC68020-Header: toplev.scm,v 4.16 89/04/26 05:09:52 GMT cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; Cross Compiler End.
+;;;; Cross Compiler End
;;; This program does not need the rest of the compiler, but should
;;; match the version of the same name in crstop.scm and toplev.scm
,x))))
(define (cross-compile-bin-file-end input-string #!optional output-string)
- (compiler-pathnames
- input-string
- (and (not (default-object? output-string)) output-string)
- (make-pathname false false false false "bits.x" 'NEWEST)
- (lambda (input-pathname output-pathname)
- output-pathname
- (cross-compile-scode-end (compiler-fasload input-pathname)))))
+ (compiler-pathnames input-string
+ (and (not (default-object? output-string)) output-string)
+ (make-pathname false false false false "bits.x" 'NEWEST)
+ (lambda (input-pathname output-pathname)
+ output-pathname ;ignore
+ (cross-compile-scode-end (compiler-fasload input-pathname)))))
+
+(define (compiler-pathnames input-string output-string default transform)
+ (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))))
(define (cross-compile-scode-end cross-compilation)
(in-compiler
(lambda ()
(cross-link-end cross-compilation)
- compiler:expression)))
+ *expression*)))
\f
(define-structure (cc-vector (constructor cc-vector/make)
(conc-name cc-vector/))
(ic-procedure-headers false read-only true))
(define (cross-link-end cc-vector)
- (set! compiler:code-vector (cc-vector/code-vector cc-vector))
- (set! compiler:entry-label (cc-vector/entry-label cc-vector))
- (set! compiler:entry-points (cc-vector/entry-points cc-vector))
- (set! compiler:label-bindings (cc-vector/label-bindings cc-vector))
+ (set! *code-vector* (cc-vector/code-vector cc-vector))
+ (set! *entry-label* (cc-vector/entry-label cc-vector))
+ (set! *entry-points* (cc-vector/entry-points cc-vector))
+ (set! *label-bindings* (cc-vector/label-bindings cc-vector))
(set! *ic-procedure-headers* (cc-vector/ic-procedure-headers cc-vector))
(phase/link))
((ucode-primitive &make-object)
type-code:compiled-entry
(make-non-pointer-object
- (+ (cdr (or (assq label compiler:label-bindings)
+ (+ (cdr (or (assq label *label-bindings*)
(error "Missing entry point" label)))
- (object-datum compiler:code-vector))))))))
- compiler:entry-points)))
+ (object-datum *code-vector*))))))))
+ *entry-points*)))
(let ((label->expression
(lambda (label)
(cdr (or (assq label bindings)
(error "Label not defined as entry point" label))))))
- (set! compiler:expression (label->expression compiler:entry-label))
+ (set! *expression* (label->expression *entry-label*))
(for-each (lambda (entry)
(set-lambda-body! (car entry)
(label->expression (cdr entry))))
*ic-procedure-headers*)))
- (set! compiler:code-vector)
- (set! compiler:entry-points)
- (set! compiler:label-bindings)
- (set! compiler:entry-label)
+ (set! *code-vector*)
+ (set! *entry-points*)
+ (set! *label-bindings*)
+ (set! *entry-label*)
(set! *ic-procedure-headers*))))
\f
-(define (compiler-pathnames input-string output-string default transform)
- (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))))
-\f
;;;; Compiler emulation
(define type-code:compiled-entry (ucode-type COMPILED-ENTRY))
(define compiler:batch-mode? false)
-(define compiler:expression)
-(define compiler:code-vector)
-(define compiler:entry-label)
-(define compiler:entry-points)
-(define compiler:label-bindings)
+(define *expression*)
+(define *code-vector*)
+(define *entry-label*)
+(define *entry-points*)
+(define *label-bindings*)
(define *ic-procedure-headers*)
(define (in-compiler thunk)
- (fluid-let ((compiler:expression)
- (compiler:code-vector)
- (compiler:entry-label)
- (compiler:entry-points)
- (compiler:label-bindings) (*ic-procedure-headers*))
+ (fluid-let ((*expression*)
+ (*code-vector*)
+ (*entry-label*)
+ (*entry-points*)
+ (*label-bindings*)
+ (*ic-procedure-headers*))
(thunk)))
(define (compiler-phase name thunk)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crstop.scm,v 1.3 1989/05/21 02:40:17 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crstop.scm,v 1.4 1989/08/21 19:32:21 cph Exp $
$MC68020-Header: toplev.scm,v 4.16 89/04/26 05:09:52 GMT cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Cross Compiler Top Level.
-;;; This code shares and should be merged with toplev.scm.
+;;; This code shares and should be merged with "toplev.scm".
;;; Many of the procedures only differ in the default extensions.
(declare (usual-integrations))
(in-compiler
(lambda ()
(cross-link-end cross-compilation)
- compiler:expression)))
+ *result*)))
\f
;; This should be merged with compile-scode
(phase/info-generation-2 info-output-pathname))
;; Here is were this procedure differs from compile-scode
(phase/cross-link)
- compiler:expression))))
+ *result*))))
\f
(define-structure (cc-vector (constructor cc-vector/make)
(conc-name cc-vector/))
(compiler-phase
"Cross Linkification"
(lambda ()
- (set! compiler:expression
- (cc-vector/make
- (last-reference compiler:code-vector)
- (last-reference compiler:entry-label)
- (last-reference compiler:entry-points)
- (last-reference compiler:label-bindings)
- (last-reference *ic-procedure-headers*)))
+ (set! *result*
+ (cc-vector/make
+ (last-reference *code-vector*)
+ (last-reference *entry-label*)
+ (last-reference *entry-points*)
+ (last-reference *label-bindings*)
+ (last-reference *ic-procedure-headers*)))
unspecific)))
(define (cross-link-end cc-vector)
- (set! compiler:code-vector (cc-vector/code-vector cc-vector))
- (set! compiler:entry-label (cc-vector/entry-label cc-vector))
- (set! compiler:entry-points (cc-vector/entry-points cc-vector))
- (set! compiler:label-bindings (cc-vector/label-bindings cc-vector)) (set! *ic-procedure-headers* (cc-vector/ic-procedure-headers cc-vector))
+ (set! *code-vector* (cc-vector/code-vector cc-vector))
+ (set! *entry-label* (cc-vector/entry-label cc-vector))
+ (set! *entry-points* (cc-vector/entry-points cc-vector))
+ (set! *label-bindings* (cc-vector/label-bindings cc-vector))
+ (set! *ic-procedure-headers* (cc-vector/ic-procedure-headers cc-vector))
(phase/link))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.9 1989/04/15 18:05:13 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.10 1989/08/21 19:32:23 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(write-string "\nOffset: ")
(write-string
(number->string (compiled-code-address->offset object)
- '(HEUR (RADIX X S))))) ((compiled-procedure? object)
- (debug/where (compiled-procedure-entry object)))
- (else
+ '(HEUR (RADIX X S))))) (else
(error "debug/where -- what?" object))))
\f
(define (compiler:write-rtl-file input-path #!optional output-path)
(for-each fg/print-blocks (block-disowned-children block)))
\f
(define (fg/print-node node)
- (if (not (node-marked? node)) (begin
+ (if (and node
+ (not (node-marked? node)))
+ (begin
(node-mark! node)
(fg/print-object node)
(cfg-node-case (tagged-vector/tag node)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/infnew.scm,v 4.4 1989/01/06 20:50:21 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/infnew.scm,v 4.5 1989/08/21 19:32:26 cph Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(or (selector object)
(error "Missing debugging info" object)))))
(values
- (debug-info rtl-expr/debugging-info expression)
+ (and expression (debug-info rtl-expr/debugging-info expression))
(map (lambda (procedure)
(let ((info (debug-info rtl-procedure/debugging-info procedure)))
(set-dbg-procedure/external-label!
(for-each (lambda (label)
(set-dbg-label/external?! (map-label label) true))
external-labels)
- (set-dbg-expression/label!
- expression
- (map-label (dbg-expression/label expression))) (for-each
+ (if expression
+ (set-dbg-expression/label!
+ expression
+ (map-label (dbg-expression/label expression))))
+ (for-each
(lambda (procedure)
(set-dbg-procedure/label!
procedure
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.10 1988/12/06 18:53:47 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.11 1989/08/21 19:32:29 cph Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define compiler:enable-integration-declarations? true)
(define compiler:enable-expansion-declarations? true)
+(define compiler:compile-by-procedures? true)
+(define compiler:show-time-reports? false)
+(define compiler:show-procedures? true)
+(define compiler:show-phases? false)
(define compiler:show-subphases? false)
(define compiler:preserve-data-structures? false)
(define compiler:code-compression? true)
'HYBRID)
(define compiler:default-top-level-declarations
- '((UUO-LINK ALL)))
\ No newline at end of file
+ '((UUO-LINK ALL)))
+
+;;; Hook: bind this to a procedure of one argument and it will receive
+;;; each phase of the compiler as a thunk. It is expected to call the
+;;; thunk after any appropriate processing.
+(define compiler:phase-wrapper
+ false)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.18 1989/06/10 23:54:04 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.19 1989/08/21 19:32:32 cph Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 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 *rtl-expression*)
-(define *rtl-procedures*)
-(define *rtl-continuations*)
-(define *rtl-graphs*)
-(define label->object)
-(define *dbg-expression*)
-(define *dbg-procedures*)
-(define *dbg-continuations*)
-
-;;; These variable names mistakenly use the format "compiler:..."
-;;; instead of the correct format, which is "*...*". Fix it sometime.
-(define compiler:external-labels)
-(define compiler:label-bindings)
-(define compiler:block-label)
-(define compiler:entry-label)
-(define compiler:bits)
-(define compiler:code-vector)
-(define compiler:entry-points)
-(define compiler:expression)
-
-(define compiler:phase-wrapper false)
-(define compiler:process-time 0)
-(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! *expressions*)
- (set! *procedures*)
- (set! *lvalues*)
- (set! *applications*)
- (set! *parallels*)
- (set! *ic-procedure-headers*)
- (set! *root-expression*)
- (set! *root-block*)
- (set! *rtl-expression*)
- (set! *rtl-procedures*)
- (set! *rtl-continuations*)
- (set! *rtl-graphs*)
- (set! label->object)
- (set! *dbg-expression*)
- (set! *dbg-procedures*)
- (set! *dbg-continuations*)
- (set! *machine-register-map*)
- (set! compiler:external-labels)
- (set! compiler:label-bindings)
- (set! compiler:block-label)
- (set! compiler:entry-label)
- (set! compiler:bits)
- (set! compiler:code-vector)
- (set! compiler:entry-points)
- (set! compiler:expression))
-\f
-(define (in-compiler-recursively thunk)
- (fluid-let ((*input-scode*)
- (*scode*)
- (*current-label-number*)
- (*constants*)
- (*blocks*)
- (*expressions*)
- (*procedures*)
- (*lvalues*)
- (*applications*)
- (*parallels*)
- (*ic-procedure-headers*)
- (*root-expression*)
- (*root-block*))
- (fluid-let ((*rtl-expression*)
- (*rtl-procedures*)
- (*rtl-continuations*)
- (*rtl-graphs*)
- (label->object)
- (*dbg-expression*)
- (*dbg-procedures*)
- (*dbg-continuations*)
- (*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
- (let ((expression (thunk)))
- (let ((others (recursive-compilation-results)))
- (if (null? others)
- expression
- (scode/make-comment
- (make-dbg-info-vector
- (list->vector
- (cons (compiled-code-address->block expression)
- (map (lambda (other) (vector-ref other 2))
- others))))
- expression))))))
- (if (not compiler:preserve-data-structures?)
- (compiler:reset!))
- (compiler-time-report "Total compilation time"
- compiler:process-time
- compiler:real-time)
- value)))
-
-(define (recursive-compilation-results)
- (sort *recursive-compilation-results*
- (lambda (x y) (< (vector-ref x 0) (vector-ref y 0)))))
-\f
-;;;; The file compiler, its usual mode.
+;;;; Usual Entry Point: File Compilation
(define (cf input #!optional output)
(let ((kernel
(compile-scode (compiler-fasload input-pathname)
(and compiler:generate-rtl-files?
(pathname-new-type output-pathname "brtl"))
- (pathname-new-type output-pathname "binf")))))
-\f
-;;;; 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 ((compiler:batch-mode? true))
- (bind-condition-handler '() compiler:batch-error-handler
- (lambda ()
- (if (default-object? output)
- (compile-bin-file input)
- (compile-bin-file input output))))))
+ (pathname-new-type output-pathname "binf"))))
+ unspecific)
-(define (compiler:batch-error-handler condition)
- (and (condition/error? condition)
- (begin (warn (condition/report-string condition))
- (compiler:abort false))))
-
-(define (compiler:abort value)
- (if compiler:abort-handled?
- (begin
- (newline)
- (display "*** Aborting...")
- (compiler:abort-continuation value))
- (error "compiler:abort: Not set up to abort" value)))
-
-(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))))))
-\f
(define (compiler-pathnames input-string output-string default transform)
(let* ((core
(lambda (input-string)
scode)))
(scan-defines scode make-open-block))))
\f
+;;;; Alternate Entry Points
+
(define (compile-procedure procedure)
(scode-eval (compile-scode (procedure-lambda procedure) false false)
(procedure-environment procedure)))
-;; The rtl output should be fixed
+(define (compiler:batch-compile input #!optional output)
+ (fluid-let ((compiler:batch-mode? true))
+ (bind-condition-handler '() compiler:batch-error-handler
+ (lambda ()
+ (if (default-object? output)
+ (compile-bin-file input)
+ (compile-bin-file input output))))))
+
+(define (compiler:batch-error-handler condition)
+ (and (not (condition/internal? condition))
+ (condition/error? condition)
+ (begin
+ (warn (condition/report-string condition))
+ (compiler:abort false))))
+
+(define (compiler:abort value)
+ (if (not compiler:abort-handled?)
+ (error "Not set up to abort" value))
+ (newline)
+ (write-string "*** Aborting...")
+ (compiler:abort-continuation value))
-(define (compile-recursively scode)
- (let ((my-number *recursive-compilation-count*))
+(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:batch-mode? false)
+(define compiler:abort-handled? false)
+(define compiler:abort-continuation)
+\f
+(define (compile-recursively scode procedure-result?)
+ ;; Used by the compiler when it wants to compile subexpressions as
+ ;; separate code-blocks.
+ ;; The rtl output should be fixed.
+ (let ((my-number *recursive-compilation-count*)
+ (output?
+ (and compiler:show-phases?
+ (not compiler:show-procedures?))))
(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)))
+ (if output?
+ (begin
+ (newline)
+ (newline)
+ (write-string *output-prefix*)
+ (write-string "*** Recursive compilation ")
+ (write my-number)
+ (write-string " ***")))
+ (let ((value
+ ((let ((do-it
+ (lambda ()
+ (fluid-let ((*recursive-compilation-number* my-number)
+ (compiler:package-optimization-level 'NONE)
+ (*procedure-result?* procedure-result?))
+ (compile-scode scode
+ (and *rtl-output-pathname* true)
+ (and *info-output-filename* true)
+ bind-compiler-variables)))))
+ (if procedure-result?
+ (let ((do-it
+ (lambda ()
+ (let ((result (do-it)))
+ (set! *remote-links*
+ (cons (cdr result) *remote-links*))
+ (car result)))))
+ (if compiler:show-procedures?
+ (lambda ()
+ (compiler-phase/visible
+ (string-append
+ "Compiling procedure: "
+ (write-to-string (lambda-name scode)))
+ do-it))
+ do-it))
+ do-it))))) (if output?
+ (begin
+ (newline)
+ (write-string *output-prefix*)
+ (write-string "*** Done with recursive compilation ")
+ (write my-number)
+ (write-string " ***")
+ (newline)))
+ value)))
+\f
+;;;; Global variables
+
+(define *recursive-compilation-count*)
+(define *recursive-compilation-number*)
+(define *recursive-compilation-results*)
+(define *recursive-compilation-rtl-blocks*)
+(define *procedure-result?*)
+(define *remote-links*)
+(define *process-time*)
+(define *real-time*)
+
+(define *info-output-filename* false)
+(define *rtl-output-pathname* false)
+
+;; First set: input to compilation
+;; Last used: phase/canonicalize-scode
+(define *input-scode*)
+
+;; First set: phase/canonicalize-scode
+;; Last used: phase/translate-scode
+(define *scode*)
+
+;; First set: phase/translate-scode
+;; Last used: phase/fg-optimization-cleanup
+(define *root-block*)
+
+;; First set: phase/translate-scode
+;; Last used: phase/rtl-generation
+(define *root-expression*)
+(define *root-procedure*)
+
+;; First set: phase/rtl-generation
+;; Last used: phase/bit-linearization
+(define *rtl-expression*)
+(define *rtl-procedures*)
+(define *rtl-continuations*)
+(define *rtl-graphs*)
+(define label->object)
+(define *rtl-root*)
+
+;; First set: phase/rtl-generation
+;; Last used: phase/link
+(define *ic-procedure-headers*)
+(define *entry-label*)
+(define *block-label*)
+
+;; First set: phase/bit-generation
+;; Last used: phase/info-generation-2
+(define *external-labels*)
+
+;; First set: phase/bit-generation
+;; Last used: phase/link
+(define *subprocedure-linking-info*)
+
+;; First set: phase/bit-linearization
+;; Last used: phase/assemble
+(define *bits*)
+
+;; First set: phase/bit-linearization
+;; Last used: phase/info-generation-2
+(define *dbg-expression*)
+(define *dbg-procedures*)
+(define *dbg-continuations*)
+
+;; First set: phase/assemble
+;; Last used: phase/link
+(define *label-bindings*)
+(define *code-vector*)
+(define *entry-points*)
+
+;; First set: phase/link
+;; Last used: result of compilation
+(define *result*)
+\f
+(define (in-compiler thunk)
+ (let ((run-compiler
+ (lambda ()
+ (let ((value
+ (let ((expression (thunk)))
+ (let ((others (recursive-compilation-results)))
+ (if (null? others)
+ expression
+ (scode/make-comment
+ (make-dbg-info-vector
+ (let* ((others
+ (map (lambda (other) (vector-ref other 2))
+ others))
+ (all-blocks
+ (list->vector
+ (cons
+ (compiled-code-address->block expression)
+ others))))
+ (if compiler:compile-by-procedures?
+ (list 'COMPILED-BY-PROCEDURES
+ all-blocks
+ (list->vector others))
+ all-blocks)))
+ expression))))))
+ (compiler-time-report "Total compilation time"
+ *process-time*
+ *real-time*)
+ value))))
+ (if compiler:preserve-data-structures?
+ (begin
+ (compiler:reset!)
+ (run-compiler))
+ (fluid-let ((*recursive-compilation-number* 0)
+ (*recursive-compilation-count* 1)
+ (*recursive-compilation-results* '())
+ (*recursive-compilation-rtl-blocks* '())
+ (*procedure-result?* false)
+ (*remote-links* '())
+ (*process-time* 0)
+ (*real-time* 0))
+ (bind-compiler-variables run-compiler)))))
+\f
+(define (bind-compiler-variables thunk)
+ ;; Split this fluid-let because compiler was choking on it.
+ (fluid-let ((*ic-procedure-headers*)
+ (*current-label-number*)
+ (*external-labels*)
+ (*block-label*)
+ (*dbg-expression*)
+ (*dbg-procedures*)
+ (*dbg-continuations*)
+ (*bits*)
+ (*next-constant*)
+ (*interned-constants*)
+ (*interned-variables*)
+ (*interned-assignments*)
+ (*interned-uuo-links*)
+ (*constants*)
+ (*blocks*)
+ (*expressions*)
+ (*procedures*)
+ (*lvalues*)
+ (*applications*)
+ (*parallels*))
+ (fluid-let ((*input-scode*)
+ (*scode*)
+ (*root-expression*)
+ (*root-procedure*)
+ (*root-block*)
+ (*rtl-expression*)
+ (*rtl-procedures*)
+ (*rtl-continuations*)
+ (*rtl-graphs*)
+ (label->object)
+ (*rtl-root*)
+ (*machine-register-map*)
+ (*entry-label*)
+ (*label-bindings*)
+ (*code-vector*)
+ (*entry-points*)
+ (*subprocedure-linking-info*)
+ (*result*))
+ (thunk))))
+
+(define (recursive-compilation-results)
+ (sort *recursive-compilation-results*
+ (lambda (x y) (< (vector-ref x 0) (vector-ref y 0)))))
+\f
+(define (compiler:reset!)
+ (set! *recursive-compilation-number* 0)
+ (set! *recursive-compilation-count* 1)
+ (set! *recursive-compilation-results* '())
+ (set! *recursive-compilation-rtl-blocks* '())
+ (set! *procedure-result?* false)
+ (set! *remote-links* '())
+ (set! *process-time* 0)
+ (set! *real-time* 0)
+ (set! *info-output-filename* false)
+ (set! *rtl-output-pathname* false)
+
+ (set! *ic-procedure-headers*)
+ (set! *current-label-number*)
+ (set! *external-labels*)
+ (set! *bits*)
+ (set! *block-label*)
+ (set! *dbg-expression*)
+ (set! *dbg-procedures*)
+ (set! *dbg-continuations*) (set! *next-constant*)
+ (set! *interned-constants*)
+ (set! *interned-variables*)
+ (set! *interned-assignments*)
+ (set! *interned-uuo-links*)
+ (set! *constants*)
+ (set! *blocks*)
+ (set! *expressions*)
+ (set! *procedures*)
+ (set! *lvalues*)
+ (set! *applications*)
+ (set! *parallels*)
+ (set! *input-scode*)
+ (set! *scode*)
+ (set! *root-expression*)
+ (set! *root-procedure*)
+ (set! *root-block*)
+ (set! *rtl-expression*)
+ (set! *rtl-procedures*)
+ (set! *rtl-continuations*)
+ (set! *rtl-graphs*)
+ (set! label->object)
+ (set! *rtl-root*)
+ (set! *machine-register-map*)
+ (set! *entry-label*)
+ (set! *label-bindings*)
+ (set! *code-vector*)
+ (set! *entry-points*)
+ (set! *subprocedure-linking-info*)
+ (set! *result*)
+ unspecific)
+\f
+;;;; Main Entry Point
(define (compile-scode scode
#!optional
rtl-output-pathname
info-output-pathname
wrapper)
-
- (if (default-object? rtl-output-pathname)
- (set! rtl-output-pathname false))
- (if (default-object? info-output-pathname)
- (set! info-output-pathname false))
-
- (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 (default-object? 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))))
+ (let ((rtl-output-pathname
+ (if (default-object? rtl-output-pathname)
+ false
+ rtl-output-pathname))
+ (info-output-pathname
+ (if (default-object? info-output-pathname)
+ false
+ info-output-pathname))
+ (wrapper
+ (if (default-object? wrapper) in-compiler wrapper)))
+ (fluid-let ((*info-output-filename*
+ (if (pathname? info-output-pathname)
+ (pathname->string info-output-pathname)
+ *info-output-filename*))
+ (*rtl-output-pathname*
+ (if (pathname? rtl-output-pathname)
+ rtl-output-pathname
+ *rtl-output-pathname*)))
+ (wrapper
+ (lambda ()
+ (set! *input-scode* scode)
+ (phase/fg-generation)
+ (phase/fg-optimization)
+ (phase/rtl-generation)
+ #|
+ ;; Current info-generation keeps state in-core.
+ (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)
+ *result*)))))
\f
(define (compiler-phase name thunk)
- (compiler-phase/visible name
- (lambda ()
- (compiler-phase/invisible thunk))))
+ (if compiler:show-phases?
+ (compiler-phase/visible name
+ (lambda ()
+ (compiler-phase/invisible thunk)))
+ (compiler-phase/invisible thunk)))
(define (compiler-superphase name thunk)
(if compiler:show-subphases?
(thunk)
- (compiler-phase/visible name thunk)))
+ (compiler-phase name thunk)))
(define (compiler-subphase name thunk)
(if compiler:show-subphases?
(compiler-phase/invisible thunk)))
(define (compiler-phase/visible name thunk)
- (newline)
- (display " ")
- (display name)
- (display "...")
- (let ((process-start (process-time-clock))
- (real-start (real-time-clock)))
- (thunk)
- (let ((process-delta (- (process-time-clock) process-start))
- (real-delta (- (real-time-clock) real-start)))
- (set! compiler:process-time (+ process-delta compiler:process-time))
- (set! compiler:real-time (+ real-delta compiler:real-time))
- (compiler-time-report " Time taken" process-delta real-delta))))
+ (fluid-let ((*output-prefix* (string-append " " *output-prefix*)))
+ (newline)
+ (write-string *output-prefix*)
+ (write-string name)
+ (write-string "...")
+ (if compiler:show-time-reports?
+ (let ((process-start *process-time*)
+ (real-start *real-time*))
+ (let ((value (thunk)))
+ (compiler-time-report " Time taken"
+ (- *process-time* process-start)
+ (- *real-time* real-start))
+ value))
+ (thunk))))
+
+(define *output-prefix* "")
+(define *phase-level* 0)
(define (compiler-phase/invisible thunk)
- (if compiler:phase-wrapper
- (compiler:phase-wrapper thunk)
- (thunk)))
+ (fluid-let ((*phase-level* (1+ *phase-level*)))
+ (let ((do-it
+ (if compiler:phase-wrapper
+ (lambda () (compiler:phase-wrapper thunk))
+ thunk)))
+ (if (= 1 *phase-level*)
+ (let ((process-start (process-time-clock))
+ (real-start (real-time-clock)))
+ (let ((value (do-it)))
+ (let ((process-delta (- (process-time-clock) process-start))
+ (real-delta (- (real-time-clock) real-start)))
+ (set! *process-time* (+ process-delta *process-time*))
+ (set! *real-time* (+ real-delta *real-time*)))
+ value))
+ (do-it)))))
(define (compiler-time-report prefix process-time real-time)
(newline)
+ (write-string *output-prefix*)
(write-string prefix)
(write-string ": ")
(write (/ process-time 1000))
(define (phase/canonicalize-scode)
(compiler-subphase "Scode Canonicalization"
(lambda ()
- (set! *scode* (canonicalize/top-level (last-reference *input-scode*))))))
+ (set! *scode* (canonicalize/top-level (last-reference *input-scode*)))
+ unspecific)))
(define (phase/translate-scode)
(compiler-subphase "Translation of Scode into Flow Graph"
(set! *applications* '())
(set! *parallels* '())
(set! *root-expression* (construct-graph (last-reference *scode*)))
+ (if *procedure-result?*
+ (let ((node (expression-entry-node *root-expression*)))
+ (if (not (and (application? node)
+ (application/return? node)))
+ (error "Entry node of procedure compilation not return" node))
+ (let ((operand (return/operand node)))
+ (if (not (procedure? operand))
+ (error "Value of procedure compilation not procedure" node))
+ (set! *root-procedure* operand))))
(set! *root-block* (expression-block *root-expression*))
(if (or (null? *expressions*)
(not (null? (cdr *expressions*))))
(error "Multiple expressions"))
- (set! *expressions*))))
+ (set! *expressions*)
+ unspecific)))
(define (phase/fg-optimization)
(compiler-superphase "Flow Graph Optimization"
(compiler-subphase "Flow Graph Optimization Cleanup"
(lambda ()
(if (not compiler:preserve-data-structures?)
- (begin (clear-call-graph! *procedures*)
- (set! *constants*)
- (set! *blocks*)
- (set! *procedures*)
- (set! *lvalues*)
- (set! *applications*)
- (set! *parallels*)
- (set! *root-block*))))))
+ (begin
+ (clear-call-graph! *procedures*)
+ (set! *constants*)
+ (set! *blocks*)
+ (set! *procedures*)
+ (set! *lvalues*)
+ (set! *applications*)
+ (set! *parallels*)
+ (set! *root-block*)
+ unspecific)))))
\f
(define (phase/rtl-generation)
(compiler-phase "RTL Generation"
(lambda ()
- (set! *rtl-procedures* '())
- (set! *rtl-continuations* '())
- (set! *rtl-graphs* '())
(set! *ic-procedure-headers* '())
(initialize-machine-register-map!)
- (generate/top-level (last-reference *root-expression*))
+ (with-values
+ (lambda ()
+ (generate/top-level (last-reference *root-expression*)))
+ (lambda (expression procedures continuations rgraphs)
+ (set! *rtl-expression* expression)
+ (set! *rtl-procedures* procedures)
+ (set! *rtl-continuations* continuations)
+ (set! *rtl-graphs* rgraphs)
+ unspecific))
+ (if *procedure-result?*
+ (set! *rtl-expression* false))
(set! label->object
(make/label->object *rtl-expression*
*rtl-procedures*
*rtl-continuations*))
+ (set! *rtl-root*
+ (if *procedure-result?*
+ (label->object
+ (procedure-label (last-reference *root-procedure*)))
+ *rtl-expression*))
(for-each (lambda (entry)
(set-cdr! entry
(rtl-procedure/external-label
(label->object (cdr entry)))))
*ic-procedure-headers*)
- (let ((n-registers
- (map (lambda (rgraph)
- (- (rgraph-n-registers rgraph)
- number-of-machine-registers))
- *rtl-graphs*)))
- (newline)
- (write-string " Registers used: ")
- (write (apply max n-registers))
- (write-string " max, ")
- (write (apply min n-registers))
- (write-string " min, ")
- (write (/ (apply + n-registers) (length n-registers)))
- (write-string " mean")))))
+ (if compiler:show-phases?
+ (let ((n-registers
+ (map (lambda (rgraph)
+ (- (rgraph-n-registers rgraph)
+ number-of-machine-registers))
+ *rtl-graphs*)))
+ (newline)
+ (write-string *output-prefix*)
+ (write-string " Registers used: ")
+ (write (apply max n-registers))
+ (write-string " max, ")
+ (write (apply min n-registers))
+ (write-string " min, ")
+ (write (/ (apply + n-registers) (length n-registers)))
+ (write-string " mean"))))))
(define (phase/rtl-optimization)
(compiler-superphase "RTL Optimization"
(compiler-phase "RTL File Output"
(lambda ()
(let ((rtl
- (linearize-rtl *rtl-expression*
+ (linearize-rtl *rtl-root*
*rtl-procedures*
*rtl-continuations*)))
(if (eq? pathname true)
;; recursive compilation
- (set! *recursive-compilation-rtl-blocks*
- (cons (cons *recursive-compilation-number* rtl)
- *recursive-compilation-rtl-blocks*))
+ (begin
+ (set! *recursive-compilation-rtl-blocks*
+ (cons (cons *recursive-compilation-number* rtl)
+ *recursive-compilation-rtl-blocks*))
+ unspecific)
(fasdump (if (null? *recursive-compilation-rtl-blocks*)
rtl
(list->vector
(cons (cons 0 rtl)
*recursive-compilation-rtl-blocks*)))
pathname))))))
-
+\f
(define (phase/bit-generation)
(compiler-phase "LAP Generation"
(lambda ()
- (set! compiler:external-labels '())
- (generate-bits
- *rtl-graphs*
- (lambda (block-label prefix)
- (set! compiler:block-label block-label)
- (node-insert-snode! (rtl-expr/entry-node *rtl-expression*)
- (make-sblock prefix))))
- (set! compiler:entry-label (rtl-expr/label *rtl-expression*)))))
-\f
+ (set! *next-constant* 0)
+ (set! *interned-constants* '())
+ (set! *interned-variables* '())
+ (set! *interned-assignments* '())
+ (set! *interned-uuo-links* '())
+ (set! *block-label* (generate-label))
+ (set! *external-labels* '())
+ (if *procedure-result?*
+ (generate-bits *rtl-graphs* '()
+ (lambda (prefix environment-label free-ref-label n-sections)
+ (node-insert-snode! (rtl-procedure/entry-node *rtl-root*)
+ (make-sblock prefix))
+ (set! *entry-label*
+ (rtl-procedure/external-label *rtl-root*))
+ (set! *subprocedure-linking-info*
+ (vector environment-label free-ref-label n-sections))
+ unspecific))
+ (begin
+ (let ((prefix (generate-bits *rtl-graphs* *remote-links* false)))
+ (node-insert-snode! (rtl-expr/entry-node *rtl-root*)
+ (make-sblock prefix)))
+ (set! *entry-label* (rtl-expr/label *rtl-root*))
+ unspecific)))))
+
(define (phase/bit-linearization)
(compiler-phase "LAP Linearization"
(lambda ()
- (set! compiler:bits
+ (set! *bits*
(append-instruction-sequences!
- (lap:make-entry-point compiler:entry-label compiler:block-label)
- (linearize-bits *rtl-expression*
+ (if *procedure-result?*
+ (LAP (ENTRY-POINT ,*entry-label*))
+ (lap:make-entry-point *entry-label* *block-label*))
+ (linearize-bits *rtl-root*
*rtl-procedures*
*rtl-continuations*)))
(with-values
(lambda (expression procedures continuations)
(set! *dbg-expression* expression)
(set! *dbg-procedures* procedures)
- (set! *dbg-continuations* continuations)))
+ (set! *dbg-continuations* continuations)
+ unspecific))
(if (not compiler:preserve-data-structures?)
- (begin (set! label->object)
- (set! *rtl-expression*)
- (set! *rtl-procedures*)
- (set! *rtl-continuations*)
- (set! *rtl-graphs*))))))
-
+ (begin
+ (set! *rtl-expression*)
+ (set! *rtl-procedures*)
+ (set! *rtl-continuations*)
+ (set! *rtl-graphs*)
+ (set! label->object)
+ (set! *rtl-root*)
+ unspecific)))))
+\f
(define (phase/assemble)
(compiler-phase "Assembly"
(lambda ()
- (assemble (last-reference compiler:block-label)
- (last-reference compiler:bits)
+ (assemble *block-label* (last-reference *bits*)
(lambda (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)
- (newline)
- (display " Branch tensioning done in ")
- (write (1+ count))
- (if (zero? count)
- (display " iteration.")
- (display " iterations.")))))))
+ linkage-info ;ignored
+ (set! *code-vector* code-vector)
+ (set! *entry-points* labels)
+ (set! *label-bindings* bindings)
+ (if compiler:show-phases?
+ (begin
+ (newline)
+ (write-string *output-prefix*)
+ (write-string " Branch tensioning done in ")
+ (write (1+ count))
+ (write-string
+ (if (zero? count) " iteration." " iterations.")))))))))
(define (phase/info-generation-2 pathname)
(compiler-phase "Debugging Information Generation"
(lambda ()
(set-compiled-code-block/debugging-info!
- compiler:code-vector
+ *code-vector*
(let ((info
(info-generation-phase-3
(last-reference *dbg-expression*)
(last-reference *dbg-procedures*)
(last-reference *dbg-continuations*)
- compiler:label-bindings
- (last-reference compiler:external-labels))))
+ *label-bindings*
+ (last-reference *external-labels*))))
(if (eq? pathname true) ; recursive compilation
(begin
(set! *recursive-compilation-results*
(cons (vector *recursive-compilation-number*
info
- compiler:code-vector)
+ *code-vector*)
*recursive-compilation-results*))
- (cons (pathname->string *info-output-pathname*)
- *recursive-compilation-number*))
+ (cons *info-output-filename* *recursive-compilation-number*))
(begin
(fasdump (let ((others (recursive-compilation-results)))
(if (null? others)
(map (lambda (other) (vector-ref other 1))
others)))))
pathname)
- (pathname->string pathname))))))))
+ *info-output-filename*)))))))
\f
(define (phase/link)
(compiler-phase "Linkification"
(lambda ()
;; This has sections locked against GC to prevent relocation
;; while computing addresses.
- (let ((bindings
- (map (lambda (label)
- (cons
- label
- (with-absolutely-no-interrupts
- (lambda ()
- ((ucode-primitive &make-object)
- type-code:compiled-entry
- (make-non-pointer-object
- (+ (cdr (or (assq label compiler:label-bindings)
- (error "Missing entry point" label)))
- (object-datum compiler:code-vector))))))))
- compiler:entry-points)))
- (let ((label->expression
- (lambda (label)
- (cdr (or (assq label bindings)
- (error "Label not defined as entry point" label))))))
- (set! compiler:expression (label->expression compiler:entry-label))
- (for-each (lambda (entry)
- (set-lambda-body! (car entry)
- (label->expression (cdr entry))))
- *ic-procedure-headers*)))
- (set! compiler:code-vector)
- (set! compiler:entry-points)
- (set! compiler:label-bindings)
- (set! compiler:entry-label)
- (set! *ic-procedure-headers*))))
\ No newline at end of file
+ (let* ((label->offset
+ (lambda (label)
+ (cdr (or (assq label *label-bindings*)
+ (error "Missing entry point" label)))))
+ (bindings
+ (map (lambda (label)
+ (cons
+ label
+ (with-absolutely-no-interrupts
+ (lambda ()
+ ((ucode-primitive &make-object)
+ type-code:compiled-entry
+ (make-non-pointer-object
+ (+ (label->offset label)
+ (object-datum *code-vector*))))))))
+ *entry-points*))
+ (label->address
+ (lambda (label)
+ (cdr (or (assq label bindings)
+ (error "Label not defined as entry point"
+ label))))))
+ (set! *result*
+ (if *procedure-result?*
+ (let ((linking-info *subprocedure-linking-info*))
+ (let ((compiled-procedure (label->address *entry-label*))
+ (translate-label
+ (let ((block-offset (label->offset *block-label*)))
+ (lambda (index)
+ (let ((label (vector-ref linking-info index)))
+ (and label
+ (- (label->offset label)
+ block-offset)))))))
+ (cons compiled-procedure
+ (vector
+ (compiled-code-address->block compiled-procedure)
+ (translate-label 0)
+ (translate-label 1)
+ (vector-ref linking-info 2)))))
+ (label->address *entry-label*)))
+ (for-each (lambda (entry)
+ (set-lambda-body! (car entry)
+ (label->address (cdr entry))))
+ *ic-procedure-headers*))
+ (if (not compiler:preserve-data-structures?)
+ (begin
+ (set! *code-vector*)
+ (set! *entry-points*)
+ (set! *subprocedure-linking-info*)
+ (set! *label-bindings*)
+ (set! *block-label*)
+ (set! *entry-label*)
+ (set! *ic-procedure-headers*)
+ unspecific)))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/canon.scm,v 1.5 1989/08/15 12:58:56 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/canon.scm,v 1.6 1989/08/21 19:33:57 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
false true false))
(define (canonicalize/lambda expr bound context)
- (canonicalize/lambda* expr bound
- (if (eq? context 'FIRST-CLASS)
- 'FIRST-CLASS
- 'ARBITRARY)))
+ (let ((canout
+ (canonicalize/lambda* expr bound
+ (if (eq? context 'FIRST-CLASS)
+ 'FIRST-CLASS
+ 'ARBITRARY))))
+ (if (and (eq? context 'TOP-LEVEL)
+ (canout-safe? canout)
+ compiler:compile-by-procedures?)
+ (make-canout
+ (scode/make-directive
+ (canout-expr canout)
+ '(COMPILE-PROCEDURE)
+ expr)
+ true
+ (canout-needs? canout)
+ (canout-splice? canout))
+ canout)))
+
(define (canonicalize/sequence expr bound context)
(cond ((not (scode/open-block? expr))
(scode/sequence-components expr
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.18 1989/08/15 12:58:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.19 1989/08/21 19:34:01 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
;; The call to `process-declarations!' must come after the
;; expression is generated because it can refer to the set of free
;; variables in the expression.
- (let ((node (generate/expression block continuation expression)))
+ (let ((scfg (generate/expression block continuation expression)))
(process-top-level-declarations! block declarations)
- node))
+ scfg))
\f
;;;; Continuations
(virtual-continuation/type continuation))
((procedure? continuation)
(continuation/type continuation))
- (else
- (error "Illegal continuation" continuation))))
+ (else (error "Illegal continuation" continuation))))
(define (continuation/type? continuation type)
(cond ((variable? continuation)
(eq? (virtual-continuation/type continuation) type))
((procedure? continuation)
(eq? (continuation/type continuation) type))
- (else
- (error "Illegal continuation" continuation))))
+ (else (error "Illegal continuation" continuation))))
(define-integrable (continuation/effect? continuation)
(continuation/type? continuation continuation-type/effect))
(cond ((variable? continuation) (make-reference block continuation true))
((procedure? continuation) continuation)
(else (error "Illegal continuation" continuation))))
+
+(define (scfg*ctype->ctype! continuation)
+ (continuation/case continuation
+ scfg*scfg->scfg!
+ scfg*scfg->scfg!
+ scfg*pcfg->pcfg!
+ scfg*subproblem->subproblem!))
\f
;;;; Subproblems
(subproblem-continuation subproblem)
(subproblem-rvalue subproblem)))
+(define (pcfg*subproblem->subproblem! pcfg consequent alternative)
+ (make-subproblem (pcfg*scfg->scfg! pcfg
+ (subproblem-prefix consequent)
+ (subproblem-prefix alternative))
+ (subproblem-continuation consequent)
+ (subproblem-rvalue alternative)))
+
(define *virtual-continuations*)
(define (virtual-continuation/make block parent type debugging)
;;;; Combinators
(define (generate/sequence block continuation expression)
- (let ((join
- (continuation/case continuation
- scfg*scfg->scfg!
- scfg*scfg->scfg!
- scfg*pcfg->pcfg!
- scfg*subproblem->subproblem!)))
+ (let ((join (scfg*ctype->ctype! continuation)))
(let ((do-action
(lambda (action continuation-type)
(generate/subproblem/effect block
(do-result (&triple-third expression)))))
(else
(error "Not a sequence" expression))))))
-\f
+
(define (generate/conditional block continuation expression)
(scode/conditional-components expression
(lambda (predicate consequent alternative)
expression)))
(let ((simple
(lambda (hooks branch)
- ((continuation/case continuation
- scfg*scfg->scfg!
- scfg*scfg->scfg!
- scfg*pcfg->pcfg!
- scfg*subproblem->subproblem!)
+ ((scfg*ctype->ctype! continuation)
(make-scfg (cfg-entry-node predicate) hooks)
(generate/expression block continuation branch)))))
(cond ((hooks-null? (pcfg-consequent-hooks predicate))
(define (generate/combination block continuation expression)
(scode/combination-components expression
(lambda (operator operands)
- (let ((make-combination
- (lambda (push continuation)
- (make-combination
- block
- (continuation-reference block continuation)
- (wrapper/subproblem/value
- block
- continuation
- (make-continuation-debugging-info 'COMBINATION-OPERAND
- expression
- 0)
- (lambda (continuation*)
- (if (scode/lambda? operator)
- (generate/lambda* block
- continuation*
- operator
- (continuation/known-type continuation)
- false)
- (generate/expression block
- continuation*
- operator))))
- (let loop ((operands operands) (index 1))
- (if (null? operands)
- '()
- (cons (generate/subproblem/value block
- continuation
- (car operands)
- 'COMBINATION-OPERAND
+ (if (eq? not operator)
+ (generate/conditional block
+ continuation
+ (scode/make-conditional (car operands) #F #T))
+ (let ((make-combination
+ (lambda (push continuation)
+ (make-combination
+ block
+ (continuation-reference block continuation)
+ (wrapper/subproblem/value
+ block
+ continuation
+ (make-continuation-debugging-info 'COMBINATION-OPERAND
expression
- index)
- (loop (cdr operands) (1+ index)))))
- push))))
- ((continuation/case continuation
- (lambda () (make-combination false continuation))
- (lambda ()
- (if (variable? continuation)
- (make-combination false continuation)
- (with-reified-continuation block
- continuation
- scfg*scfg->scfg!
- (lambda (push continuation)
- (make-scfg
- (cfg-entry-node (make-combination push continuation))
- (continuation/next-hooks continuation))))))
- (lambda ()
- (if (eq? not operator)
- (pcfg*pcfg->pcfg!
- (generate/subproblem/predicate block
- continuation
- (car operands)
- 'COMBINATION-OPERAND
- expression
- 1)
- (generate/expression block continuation false)
- (generate/expression block continuation true))
+ 0)
+ (lambda (continuation*)
+ (if (scode/lambda? operator)
+ (generate/lambda*
+ block
+ continuation*
+ operator
+ (continuation/known-type continuation)
+ false)
+ (generate/expression block
+ continuation*
+ operator))))
+ (let loop ((operands operands) (index 1))
+ (if (null? operands)
+ '()
+ (cons (generate/subproblem/value block
+ continuation
+ (car operands)
+ 'COMBINATION-OPERAND
+ expression
+ index)
+ (loop (cdr operands) (1+ index)))))
+ push))))
+ ((continuation/case continuation
+ (lambda () (make-combination false continuation))
+ (lambda ()
+ (if (variable? continuation)
+ (make-combination false continuation)
+ (with-reified-continuation block
+ continuation
+ scfg*scfg->scfg!
+ (lambda (push continuation)
+ (make-scfg
+ (cfg-entry-node (make-combination push continuation))
+ (continuation/next-hooks continuation))))))
+ (lambda ()
(with-reified-continuation block
continuation
scfg*pcfg->pcfg!
(cfg-entry-node (make-combination push continuation))
(continuation/next-hooks continuation))
(make-true-test block
- (continuation/rvalue continuation)))))))
- (lambda ()
- (with-reified-continuation block
- continuation
- scfg*subproblem->subproblem!
- (lambda (push continuation)
- (make-subproblem/canonical
- (make-combination push continuation)
- continuation))))))))))
+ (continuation/rvalue continuation))))))
+ (lambda ()
+ (with-reified-continuation block
+ continuation
+ scfg*subproblem->subproblem!
+ (lambda (push continuation)
+ (make-subproblem/canonical
+ (make-combination push continuation)
+ continuation)))))))))))
\f
;;;; Assignments
(generate/expression block continuation expression))
((COMPILE)
(if (not (scode/quotation? expression))
- (error "generate/comment: Bad compile directive" comment))
+ (error "Bad compile directive" comment))
(continue/rvalue-constant block continuation
(make-constant
- (compile-recursively (scode/quotation-expression expression))))) ((ENCLOSE)
+ (compile-recursively
+ (scode/quotation-expression expression false))))) ((COMPILE-PROCEDURE)
+ (if (not (scode/lambda? expression))
+ (error "Bad compile-procedure directive" comment))
+ (continue/rvalue-constant block continuation
+ (make-constant (compile-recursively expression true)))) ((ENCLOSE)
(generate/enclose block continuation expression))
(else
(warn "generate/comment: Unknown directive" (cadr text) comment)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/simapp.scm,v 4.4 1988/12/12 21:30:21 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/simapp.scm,v 4.5 1989/08/21 19:34:13 cph Rel $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(lvalue-connect! (car parameters) (car operands))
(loop (cdr parameters) (cdr operands)))))))
((rvalue/constant? operator)
- (let ((value (constant-value operator)))
- (cond ((primitive-procedure? value)
- (if (not
- (primitive-arity-correct? value
- (-1+ number-supplied)))
- (warn
- "Primitive called with wrong number of arguments"
- value
- number-supplied)))
- ((not (unassigned-reference-trap? value))
- (warn "Inapplicable operator" value)))))
+ (let ((value (constant-value operator))
+ (argument-count (-1+ number-supplied)))
+ (if (not
+ (cond ((eq? value compiled-error-procedure)
+ (positive? argument-count))
+ ((or (primitive-procedure? value)
+ (compiled-procedure? value))
+ (procedure-arity-valid? value argument-count))
+ (else
+ (if (not (unassigned-reference-trap? value))
+ (warn "Inapplicable operator" value))
+ true)))
+ (warn
+ "Procedure called with wrong number of arguments"
+ value
+ number-supplied))))
(else
(warn "Inapplicable operator" operator)))))))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.pkg,v 1.23 1989/07/25 13:06:04 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.pkg,v 1.24 1989/08/21 19:33:33 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
compiler:analyze-side-effects?
compiler:cache-free-variables?
compiler:code-compression?
+ compiler:compile-by-procedures?
compiler:cse?
compiler:default-top-level-declarations
compiler:enable-expansion-declarations?
compiler:optimize-environments?
compiler:package-optimization-level
compiler:preserve-data-structures?
- compiler:show-subphases?))
+ compiler:show-phases?
+ compiler:show-procedures?
+ compiler:show-subphases?
+ compiler:show-time-reports?))
\f
(define-package (compiler reference-contexts)
(files "base/refctx")
*rtl-graphs*
*rtl-procedures*)
(export (compiler lap-syntaxer)
- compiler:external-labels
+ *block-label*
+ *external-labels*
label->object)
(export (compiler debug)
*root-expression*
lap:make-unconditional-branch
lap:syntax-instruction)
(export (compiler top-level)
+ *interned-assignments*
+ *interned-constants*
+ *interned-uuo-links*
+ *interned-variables*
+ *next-constant*
generate-bits)
(import (scode-optimizer expansion)
scode->scode-expander))
compiler:disassemble)
(import (runtime compiler-info)
compiled-code-block/dbg-info
- dbg-info-vector/items dbg-info-vector?
+ dbg-info-vector/blocks-vector
+ dbg-info-vector?
dbg-info/labels
dbg-label/external?
dbg-label/name
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.sf,v 1.9 1989/08/03 23:43:05 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.sf,v 1.10 1989/08/21 19:33:37 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(in-package (->environment '(COMPILER LAP-SYNTAXER))
(if (and compiler:enable-expansion-declarations?
(null? early-instructions))
- (fluid-let ((load-noisily? false))
+ (fluid-let ((load-noisily? false)
+ (load/suppress-loading-message? false))
+ (write-string "\n\n---- Pre-loading instruction sets ----")
(for-each (lambda (name)
- (write-string "\nPre-loading instruction set from ")
- (write name)
(load (string-append "machines/bobcat/" name ".scm")
'(COMPILER LAP-SYNTAXER)
- early-syntax-table)
- (write-string " -- done")) '("instr1" "instr2" "instr3" "instr4"
+ early-syntax-table))
+ '("instr1" "instr2" "instr3" "instr4"
"flinstr1" "flinstr2")))))
;; Resyntax any files that need it.
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 4.12 1989/08/11 02:29:41 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 4.13 1989/08/21 19:33:40 cph Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(let ((pathname (->pathname filename)))
(with-output-to-file (pathname-new-type pathname "lap")
(lambda ()
- (let ((object (fasload (pathname-new-type pathname "com")))
- (info (let ((pathname (pathname-new-type pathname "binf")))
- (and (if (default-object? symbol-table?)
- (file-exists? pathname)
- symbol-table?)
- (fasload pathname)))))
- (cond ((compiled-code-address? object)
- (disassembler/write-compiled-code-block
- (compiled-code-address->block object)
- info
- false))
- ((not (scode/comment? object))
- (error "compiler:write-lap-file : Not a compiled file"
- (pathname-new-type pathname "com")))
- (else
- (scode/comment-components
- object
- (lambda (text expression)
- expression ;; ignored
- (if (dbg-info-vector? text)
- (let ((items (dbg-info-vector/items text)))
- (for-each disassembler/write-compiled-code-block
- (vector->list items)
- (if (false? info)
- (make-list (vector-length items) false)
- (vector->list info))))
- (error "compiler:write-lap-file : Not a compiled file"
- (pathname-new-type pathname "com"))))))))))))
+ (let ((com-file (pathname-new-type pathname "com")))
+ (let ((object (fasload com-file))
+ (info
+ (let ((pathname (pathname-new-type pathname "binf")))
+ (and (if (default-object? symbol-table?)
+ (file-exists? pathname)
+ symbol-table?)
+ (fasload pathname)))))
+ (if (compiled-code-address? object)
+ (disassembler/write-compiled-code-block
+ (compiled-code-address->block object)
+ info)
+ (begin
+ (if (not
+ (and (scode/comment? object)
+ (dbg-info-vector? (scode/comment-text object))))
+ (error "Not a compiled file" com-file))
+ (let ((items
+ (vector->list
+ (dbg-info-vector/blocks-vector
+ (scode/comment-text object)))))
+ (if (not (null? items))
+ (if (false? info)
+ (let loop ((items items))
+ (disassembler/write-compiled-code-block
+ (car items)
+ false)
+ (if (not (null? (cdr items)))
+ (begin
+ (write-char #\page)
+ (loop (cdr items)))))
+ (let loop
+ ((items items) (info (vector->list info)))
+ (disassembler/write-compiled-code-block
+ (car items)
+ (car info))
+ (if (not (null? (cdr items)))
+ (begin
+ (write-char #\page)
+ (loop (cdr items) (cdr info))))))))))))))))
(define disassembler/base-address)
(define compiled-code-block/objects-per-procedure-cache)
(define compiled-code-block/objects-per-variable-cache)
-(define (write-block block)
- (write-string "#[COMPILED-CODE-BLOCK ")
- (write-string
- (number->string (object-hash block) '(HEUR (RADIX D S))))
- (write-string " ")
- (write-string
- (number->string (object-datum block) '(HEUR (RADIX X E))))
- (write-string "]"))
-
-(define (disassembler/write-compiled-code-block block info #!optional page?)
+(define (disassembler/write-compiled-code-block block info)
(let ((symbol-table (and info (dbg-info/labels info))))
- (if (or (default-object? page?) page?)
- (begin
- (write-char #\page)
- (newline)))
(write-string "Disassembly of ")
- (write-block block)
+ (write block)
(write-string ":\n")
(write-string "Code:\n\n")
(disassembler/write-instruction-stream
(fluid-let ((*unparser-radix* 16))
(disassembler/for-each-instruction instruction-stream
(lambda (offset instruction)
- (disassembler/write-instruction
- symbol-table
- offset
- (lambda ()
- (let ((string
- (with-output-to-string
- (lambda ()
- (display instruction)))))
- (string-downcase! string)
- (write-string string))))))))
+ (disassembler/write-instruction symbol-table
+ offset
+ (lambda () (display instruction)))))))
(define (disassembler/for-each-instruction instruction-stream procedure)
(let loop ((instruction-stream instruction-stream))
(let ((label
(disassembler/lookup-symbol symbol-table offset)))
(if label
- (write-string (string-downcase label))
+ (write-string label)
(write offset))))
(write-string ")")))))
((compiled-code-address? constant)
(write-string " (offset ")
(write (compiled-code-address->offset constant))
(write-string " in ")
- (write-block (compiled-code-address->block constant))
+ (write (compiled-code-address->block constant))
(write-string ")"))
(else false)))
\f
(if label
(begin
(write-char #\Tab)
- (write-string (string-downcase (dbg-label/name label))) (write-char #\:)
+ (write-string (dbg-label/name label))
+ (write-char #\:)
(newline)))))
(if disassembler/write-addresses?
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.48 1989/08/15 12:59:19 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.49 1989/08/21 19:33:43 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
((package/reference (find-package name) 'INITIALIZE-PACKAGE!)))
'((COMPILER MACROS)
(COMPILER DECLARATIONS)))
-(add-system! (make-system "Liar (Motorola MC68020)" 4 48 '()))
\ No newline at end of file
+(add-system! (make-system "Liar (Motorola MC68020)" 4 49 '()))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.15 1988/12/30 07:05:20 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.16 1989/08/21 19:33:47 cph Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(LAP ,@set-extension
,@(clear-map!)
,(load-dnw frame-size 0)
- (LEA (@PCR ,*block-start-label*) (A 1))
+ (LEA (@PCR ,*block-label*) (A 1))
(JMP ,entry:compiler-cache-reference-apply))))
(define-rule statement
;;;; External Labels
(define (make-external-label code label)
- (set! compiler:external-labels
- (cons label compiler:external-labels))
+ (set! *external-labels* (cons label *external-labels*))
(LAP (DC UW ,code)
(BLOCK-OFFSET ,label)
(LABEL ,label)))
;;;; Entry Header
;;; This is invoked by the top level of the LAP generator.
-(define generate/quotation-header
- (let ((uuo-link-tag 0)
- (reference-tag 1)
- (assignment-tag 2))
-
- (define (make-constant-block-tag tag datum)
- (if (> datum #xffff)
- (error "make-constant-block-tag: datum too large" datum)
- (+ (* tag #x10000) datum)))
-
- (define (declare-constants tag constants info)
- (define (inner constants)
- (if (null? constants)
- (cdr info)
- (let ((entry (car constants)))
- (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry))
- ,@(inner (cdr constants))))))
-
- (if (and tag (not (null? constants)))
- (let ((label (allocate-constant-label)))
- (cons label
- (inner `((,(make-constant-block-tag tag (length constants))
- . ,label)
- ,@constants))))
- (cons (car info) (inner constants))))
-
- (define (transmogrifly uuos)
- (define (inner name assoc)
- (if (null? assoc)
- (transmogrifly (cdr uuos))
- (cons (cons name (cdar assoc)) ; uuo-label
- (cons (cons (caar assoc) ; frame-size
- (allocate-constant-label))
- (inner name (cdr assoc))))))
- (if (null? uuos)
- '()
- (inner (caar uuos) (cdar uuos))))
-
- (lambda (block-label constants references assignments uuo-links)
- (let ((constant-info
- (declare-constants uuo-link-tag (transmogrifly uuo-links)
- (declare-constants reference-tag references
- (declare-constants assignment-tag assignments
- (declare-constants #f constants
- (cons '() (LAP))))))))
- (let ((free-ref-label (car constant-info))
- (constants-code (cdr constant-info))
- (debugging-information-label (allocate-constant-label))
- (environment-label (allocate-constant-label)))
- (LAP ,@constants-code
- ;; Place holder for the debugging info filename
- (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO)
- ;; Place holder for the load time environment if needed
- (SCHEME-OBJECT ,environment-label
- ,(if (null? free-ref-label) 0 'ENVIRONMENT))
- ,@(if (null? free-ref-label)
- (LAP)
- (LAP (LEA (@PCR ,environment-label) (A 0))
- (MOV L ,reg:environment (@A 0))
- (LEA (@PCR ,block-label) (A 0))
- (LEA (@PCR ,free-ref-label) (A 1))
- ,(load-dnw (+ (if (null? uuo-links) 0 1)
- (if (null? references) 0 1)
- (if (null? assignments) 0 1))
- 0)
- (JSR ,entry:compiler-link)
- ,@(make-external-label (continuation-code-word false)
- (generate-label))))))))))
+(define (generate/quotation-header environment-label free-ref-label n-sections)
+ (LAP (LEA (@PCR ,environment-label) (A 0))
+ (MOV L ,reg:environment (@A 0))
+ (LEA (@PCR ,*block-label*) (A 0))
+ (LEA (@PCR ,free-ref-label) (A 1))
+ ,(load-dnw n-sections 0)
+ (JSR ,entry:compiler-link)
+ ,@(make-external-label (continuation-code-word false)
+ (generate-label))))
+
+(define (generate/remote-link code-block-label
+ environment-offset
+ free-ref-offset
+ n-sections)
+ (LAP (MOV L (@PCR ,code-block-label) (D 0))
+ (AND L ,mask-reference (D 0))
+ (MOV L (D 0) (A 0))
+ (LEA (@AO 0 ,environment-offset) (A 1))
+ (MOV L ,reg:environment (@A 1))
+ (LEA (@AO 0 ,free-ref-offset) (A 1))
+ ,(load-dnw n-sections 0)
+ (JSR ,entry:compiler-link)
+ ,@(make-external-label (continuation-code-word false)
+ (generate-label))))
+\f
+(define (generate/constants-block constants references assignments uuo-links)
+ (let ((constant-info
+ (declare-constants 0 (transmogrifly uuo-links)
+ (declare-constants 1 references
+ (declare-constants 2 assignments
+ (declare-constants false constants
+ (cons false (LAP))))))))
+ (let ((free-ref-label (car constant-info))
+ (constants-code (cdr constant-info))
+ (debugging-information-label (allocate-constant-label))
+ (environment-label (allocate-constant-label))
+ (n-sections
+ (+ (if (null? uuo-links) 0 1)
+ (if (null? references) 0 1)
+ (if (null? assignments) 0 1))))
+ (values
+ (LAP ,@constants-code
+ ;; Place holder for the debugging info filename
+ (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO)
+ ;; Place holder for the load time environment if needed
+ (SCHEME-OBJECT ,environment-label
+ ,(if (null? free-ref-label) 0 'ENVIRONMENT)))
+ environment-label
+ free-ref-label
+ n-sections))))
+
+(define (declare-constants tag constants info)
+ (define (inner constants)
+ (if (null? constants)
+ (cdr info)
+ (let ((entry (car constants)))
+ (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry))
+ ,@(inner (cdr constants))))))
+ (if (and tag (not (null? constants)))
+ (let ((label (allocate-constant-label)))
+ (cons label
+ (inner
+ `((,(let ((datum (length constants)))
+ (if (> datum #xffff)
+ (error "datum too large" datum))
+ (+ (* tag #x10000) datum))
+ . ,label)
+ ,@constants))))
+ (cons (car info) (inner constants))))
+
+(define (transmogrifly uuos)
+ (define (inner name assoc)
+ (if (null? assoc)
+ (transmogrifly (cdr uuos))
+ (cons (cons name (cdar assoc)) ; uuo-label
+ (cons (cons (caar assoc) ; frame-size
+ (allocate-constant-label))
+ (inner name (cdr assoc))))))
+ (if (null? uuos)
+ '()
+ (inner (caar uuos) (cdar uuos))))
\f
;;; Local Variables: ***
;;; eval: (put 'declare-constants 'scheme-indent-hook 2) ***
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtline.scm,v 4.8 1988/11/06 14:49:45 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtline.scm,v 4.9 1989/08/21 19:34:24 cph Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
initial-value
instruction-append!
final-value)
- expression procedures continuations)
+ root procedures continuations)
continuations ;ignore
(with-new-node-marks
(lambda ()
output
(bblock-linearize bblock
queue-continuations!)))))))
- (process-bblock! (rtl-expr/entry-node expression)) (queue-map!/unsafe input-queue process-bblock!)
+ (process-bblock!
+ (cond ((rtl-expr? root) (rtl-expr/entry-node root))
+ ((rtl-procedure? root) (rtl-procedure/entry-node root))
+ (else (error "Illegal linearization root" root))))
+ (queue-map!/unsafe input-queue process-bblock!)
(for-each (lambda (procedure)
(process-bblock! (rtl-procedure/entry-node procedure))
(queue-map!/unsafe input-queue process-bblock!))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlobj.scm,v 4.6 1989/08/10 11:39:55 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlobj.scm,v 4.7 1989/08/21 19:34:27 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(let ((hash-table
(symbol-hash-table/make
(1+ (+ (length procedures) (length continuations))))))
- (symbol-hash-table/insert! hash-table
- (rtl-expr/label expression)
- expression) (for-each (lambda (procedure)
+ (if expression
+ (symbol-hash-table/insert! hash-table
+ (rtl-expr/label expression)
+ expression))
+ (for-each (lambda (procedure)
(symbol-hash-table/insert! hash-table
(rtl-procedure/label procedure)
procedure))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.19 1989/08/08 01:21:29 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.20 1989/08/21 19:34:39 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(define *generation-queue*)
(define *queued-procedures*)
(define *queued-continuations*)
-
+(define *rgraphs*)
+(define *procedures*)
+(define *continuations*)
(define *extra-continuations*)
(define (generate/top-level expression)
(lambda ()
(fluid-let ((*generation-queue* (make-queue))
(*queued-procedures* '())
- (*queued-continuations* '()))
- (set! *extra-continuations* '())
- (set! *rtl-expression* (generate/expression expression))
- (queue-map!/unsafe *generation-queue* (lambda (thunk) (thunk)))
- (set! *rtl-graphs*
- (list-transform-positive (reverse! *rtl-graphs*)
- (lambda (rgraph)
- (not (null? (rgraph-entry-edges rgraph))))))
- (for-each (lambda (rgraph)
- (rgraph/compress! rgraph)
- (rgraph/postcompress! rgraph))
- *rtl-graphs*)
- (set! *rtl-procedures* (reverse! *rtl-procedures*))
- (set! *rtl-continuations*
- (append *extra-continuations* (reverse! *rtl-continuations*)))))))
+ (*queued-continuations* '())
+ (*rgraphs* '())
+ (*procedures* '())
+ (*continuations* '())
+ (*extra-continuations* '()))
+ (let ((expression (generate/expression expression)))
+ (queue-map!/unsafe *generation-queue* (lambda (thunk) (thunk)))
+ (let ((rgraphs
+ (list-transform-positive (reverse! *rgraphs*)
+ (lambda (rgraph)
+ (not (null? (rgraph-entry-edges rgraph)))))))
+ (for-each (lambda (rgraph)
+ (rgraph/compress! rgraph)
+ (rgraph/postcompress! rgraph))
+ rgraphs)
+ (values expression
+ (reverse! *procedures*)
+ (append *extra-continuations* (reverse! *continuations*))
+ rgraphs)))))))
(define (enqueue-procedure! procedure)
(if (not (memq procedure *queued-procedures*))
(begin
(enqueue!/unsafe *generation-queue*
- (lambda ()
- (set! *rtl-procedures*
- (cons (generate/procedure procedure)
- *rtl-procedures*))))
- (set! *queued-procedures* (cons procedure *queued-procedures*)))))
+ (lambda ()
+ (set! *procedures*
+ (cons (generate/procedure procedure) *procedures*))
+ unspecific))
+ (set! *queued-procedures* (cons procedure *queued-procedures*))
+ unspecific)))
(define (enqueue-continuation! continuation)
(if (not (memq continuation *queued-continuations*))
(begin
(enqueue!/unsafe *generation-queue*
- (lambda ()
- (set! *rtl-continuations*
- (cons (generate/continuation continuation)
- *rtl-continuations*))))
+ (lambda ()
+ (set! *continuations*
+ (cons (generate/continuation continuation) *continuations*))
+ unspecific))
(set! *queued-continuations*
- (cons continuation *queued-continuations*)))))
+ (cons continuation *queued-continuations*))
+ unspecific)))
\f
(define (generate/expression expression)
(with-values
(or (subgraph-color/rgraph color)
(let ((rgraph (make-rgraph number-of-machine-registers)))
(set-subgraph-color/rgraph! color rgraph)
- (set! *rtl-graphs* (cons rgraph *rtl-graphs*)) rgraph))))
+ (set! *rgraphs* (cons rgraph *rgraphs*))
+ rgraph))))
(define (generate/node node)
(let ((memoization (cfg-node-get node memoization-tag)))
projects / mit-scheme.git / commitdiff