#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bittop.scm,v 1.14 1991/05/06 22:48:40 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bittop.scm,v 1.15 1992/06/12 01:43:44 jinx Exp $
-Copyright (c) 1988-1991 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(let* ((count (relax! directives vars))
(block (assemble-objects (final-phase directives))))
(values count
- (object-new-type (ucode-type compiled-code-block) block)
+ block
(queue->list *entry-points*)
(symbol-table->assq-list *the-symbol-table*)
(queue->list *linkage-info*)))))))
code-block))
(define (assemble-objects code-block)
- (let* ((objects (queue->list *objects*))
- (bl (quotient (bit-string-length code-block)
- scheme-object-width))
- (output-block (make-vector (1+ (+ (length objects) bl)))))
- (let ((non-pointer-length
- ((ucode-primitive make-non-pointer-object) bl)))
- (with-absolutely-no-interrupts
- (lambda ()
- (vector-set! output-block 0
- ((ucode-primitive primitive-object-set-type)
- (ucode-type manifest-nm-vector)
- non-pointer-length)))))
- (write-bits! output-block
- ;; After header just inserted.
- (* scheme-object-width 2)
- code-block)
- (insert-objects! output-block objects (1+ bl))
- output-block))
+ (let ((objects (queue->list *objects*)))
+ (if compiler:cross-compiling?
+ (vector 'DEBUGGING-INFO-SLOT code-block objects scheme-object-width)
+ (let* ((bl (quotient (bit-string-length code-block)
+ scheme-object-width))
+ (non-pointer-length
+ ((ucode-primitive make-non-pointer-object) bl))
+ (output-block (make-vector (1+ (+ (length objects) bl)))))
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (vector-set! output-block 0
+ ((ucode-primitive primitive-object-set-type)
+ (ucode-type manifest-nm-vector)
+ non-pointer-length))))
+ (write-bits! output-block
+ ;; After header just inserted.
+ (* scheme-object-width 2)
+ code-block)
+ (insert-objects! output-block objects (1+ bl))
+ (object-new-type (ucode-type compiled-code-block)
+ output-block)))))
(define (insert-objects! v objects where)
(cond ((not (null? objects))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crsend.scm,v 1.7 1992/04/17 22:55:50 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crsend.scm,v 1.8 1992/06/12 01:43:04 jinx Exp $
Copyright (c) 1988-1992 Massachusetts Institute of Technology
(cross-compile-scode-end (fasload input-pathname)))))
(define (compiler-pathnames input-string output-string default transform)
- (let* ((core
+ (let ((kernel
(lambda (input-string)
(let ((input-pathname (merge-pathnames input-string default)))
(let ((output-pathname
(write-string " => ")
(write (enough-namestring output-pathname))
(fasdump (transform input-pathname output-pathname)
- output-pathname)))))
- (kernel
- (if compiler:batch-mode?
- (batch-kernel core)
- core)))
+ output-pathname))))))
(if (pair? input-string)
(for-each kernel input-string)
(kernel input-string))))
-(define compiler:batch-mode?
- false)
-
(define (cross-compile-scode-end cross-compilation)
(let ((compile-by-procedures? (vector-ref cross-compilation 0))
(expression (cross-link-end (vector-ref cross-compilation 1)))
all-blocks)))
expression))))
\f
+(define-structure (cc-code-block (type vector)
+ (conc-name cc-code-block/))
+ (debugging-info false read-only false)
+ (bit-string false read-only true)
+ (objects false read-only true)
+ (object-width false read-only true))
+
(define-structure (cc-vector (constructor cc-vector/make)
(conc-name cc-vector/))
(code-vector false read-only true)
(label-bindings false read-only true)
(ic-procedure-headers false read-only true))
-(define (cross-link-end cc-vector)
+(define (cross-link-end object)
+ (let ((code-vector (cc-vector/code-vector object)))
+ (cross-link/process-code-vector
+ (cond ((compiled-code-block? code-vector)
+ code-vector)
+ ((vector? code-vector)
+ (let ((new-code-vector (cross-link/finish-assembly
+ (cc-code-block/bit-string code-vector)
+ (cc-code-block/objects code-vector)
+ (cc-code-block/object-width code-vector))))
+ (set-compiled-code-block/debugging-info!
+ new-code-vector
+ (cc-code-block/debugging-info code-vector))
+ new-code-vector))
+ (else
+ (error "cross-link-end: Unexpected code-vector"
+ code-vector object)))
+ object)))
+
+(define (cross-link/process-code-vector code-vector cc-vector)
(let ((bindings
- (let ((code-vector (cc-vector/code-vector cc-vector))
- (label-bindings (cc-vector/label-bindings cc-vector)))
+ (let ((label-bindings (cc-vector/label-bindings cc-vector)))
(map (lambda (label)
(cons
label
(lambda ()
(let-syntax ((ucode-primitive
(macro (name)
- (make-primitive-procedure name))))
- ((ucode-primitive primitive-object-set-type)
- type-code:compiled-entry
+ (make-primitive-procedure name)))
+ (ucode-type
+ (macro (name)
+ (microcode-type name))))
+ ((ucode-primitive PRIMITIVE-OBJECT-SET-TYPE)
+ (ucode-type COMPILED-ENTRY)
(make-non-pointer-object
(+ (cdr (or (assq label label-bindings)
(error "Missing entry point" label)))
(label->expression (cdr entry))))
(cc-vector/ic-procedure-headers cc-vector))
expression))))
+\f
+(define (cross-link/finish-assembly code-block objects scheme-object-width)
+ (let-syntax ((ucode-primitive
+ (macro (name)
+ (make-primitive-procedure name)))
+ (ucode-type
+ (macro (name)
+ (microcode-type name))))
+ (let* ((bl (quotient (bit-string-length code-block)
+ scheme-object-width))
+ (non-pointer-length
+ ((ucode-primitive make-non-pointer-object) bl))
+ (output-block (make-vector (1+ (+ (length objects) bl)))))
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (vector-set! output-block 0
+ ((ucode-primitive primitive-object-set-type)
+ (ucode-type manifest-nm-vector)
+ non-pointer-length))))
+ (write-bits! output-block
+ ;; After header just inserted.
+ (* scheme-object-width 2)
+ code-block)
+ (insert-objects! output-block objects (1+ bl))
+ (object-new-type (ucode-type compiled-code-block)
+ output-block))))
-(define type-code:compiled-entry
- (microcode-type 'COMPILED-ENTRY))
\ No newline at end of file
+(define (insert-objects! v objects where)
+ (cond ((not (null? objects))
+ (vector-set! v where (cadar objects))
+ (insert-objects! v (cdr objects) (1+ where)))
+ ((not (= where (vector-length v)))
+ (error "insert-objects!: object phase error" where))
+ (else
+ unspecific)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crstop.scm,v 1.9 1991/11/04 20:35:26 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crstop.scm,v 1.10 1992/06/12 01:43:21 jinx Exp $
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(lambda (lap-output-port)
(cross-compile-scode (compiler-fasload input-pathname)
(pathname-new-type output-pathname
- "fnib")
+ "fni")
rtl-output-port
lap-output-port)))))))))
(wrapper
(if (default-object? wrapper) in-compiler wrapper)))
(fluid-let ((compiler:compile-by-procedures? false)
+ (compiler:cross-compiling? true)
+ (compiler:dump-info-file compiler:dump-inf-file)
(*info-output-filename*
(if (pathname? info-output-pathname)
(->namestring info-output-pathname)
(if lap-output-port
(phase/lap-file-output lap-output-port))
(phase/assemble)
+ ;; Here is were this procedure differs
+ ;; from compile-scode
(if info-output-pathname
- (phase/info-generation-2 info-output-pathname))
- ;; Here is were this procedure differs from compile-scode
- (phase/cross-link)
+ (cross-compiler-phase/info-generation-2 info-output-pathname))
+ (cross-compiler-phase/link)
*result*)))))
\f
+(define-structure (cc-code-block (type vector)
+ (conc-name cc-code-block/))
+ (debugging-info false read-only false)
+ (bit-string false read-only true)
+ (objects false read-only true)
+ (object-width false read-only true))
+
(define-structure (cc-vector (constructor cc-vector/make)
(conc-name cc-vector/))
(code-vector false read-only true)
(label-bindings false read-only true)
(ic-procedure-headers false read-only true))
-(define (phase/cross-link)
+(define (cross-compiler-phase/info-generation-2 pathname)
+ (info-generation-2 pathname set-cc-code-block/debugging-info!))
+
+(define (cross-compiler-phase/link)
(compiler-phase
"Cross Linkification"
(lambda ()
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/make.scm,v 4.90 1992/04/13 04:44:50 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/make.scm,v 4.91 1992/06/12 01:43:36 jinx Exp $
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(initialize-package! '(COMPILER DECLARATIONS)))
(add-system!
(make-system (string-append "Liar (" architecture-name ")")
- 4 90
+ 4 91
'())))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.17 1992/04/07 03:50:41 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.18 1992/06/12 01:43:29 jinx Exp $
-Copyright (c) 1988-92 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 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:open-code-flonum-checks? false)
(define compiler:use-multiclosures? true)
(define compiler:coalescing-constant-warnings? true)
+(define compiler:cross-compiling? false)
;; The switch COMPILER:OPEN-CODE-FLOATING-POINT-ARITHMETIC? is in machin.scm.
;;; Nary switches
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.42 1992/05/27 02:09:00 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.43 1992/06/12 01:43:14 jinx Exp $
Copyright (c) 1988-1992 Massachusetts Institute of Technology
(kernel input))))
(define (compile-bin-file input-string #!optional output-string)
- (compiler-pathnames input-string
- (and (not (default-object? output-string)) output-string)
- (make-pathname false false false false "bin" 'NEWEST)
- (lambda (input-pathname output-pathname)
- (maybe-open-file compiler:generate-rtl-files?
- (pathname-new-type output-pathname "rtl")
- (lambda (rtl-output-port)
- (maybe-open-file compiler:generate-lap-files?
- (pathname-new-type output-pathname "lap")
- (lambda (lap-output-port)
- (compile-scode/internal
- (compiler-fasload input-pathname)
- (pathname-new-type output-pathname "inf")
- rtl-output-port
- lap-output-port)))))))
- unspecific)
+ (if compiler:cross-compiling?
+ (apply cross-compile-bin-file
+ (cons input-string (if (default-object? output-string)
+ '()
+ (list output-string))))
+ (begin
+ (compiler-pathnames
+ input-string
+ (and (not (default-object? output-string)) output-string)
+ (make-pathname false false false false "bin" 'NEWEST)
+ (lambda (input-pathname output-pathname)
+ (maybe-open-file
+ compiler:generate-rtl-files?
+ (pathname-new-type output-pathname "rtl")
+ (lambda (rtl-output-port)
+ (maybe-open-file compiler:generate-lap-files?
+ (pathname-new-type output-pathname "lap")
+ (lambda (lap-output-port)
+ (compile-scode/internal
+ (compiler-fasload input-pathname)
+ (pathname-new-type output-pathname "inf")
+ rtl-output-port
+ lap-output-port)))))))
+ unspecific)))
(define (maybe-open-file open? pathname receiver)
(if open?
(if (not (zero? *recursive-compilation-number*))
(begin
(write-char #\page port)
- (newline port))))))
+ (newline port)))
+ (output-port/flush-output port))))
\f
(define (phase/lap-generation)
(compiler-phase "LAP Generation"
(if (not (zero? *recursive-compilation-number*))
(begin
(write-char #\page)
- (newline)))))))))
+ (newline)))
+ (output-port/flush-output port)))))))
(define (phase/assemble)
(compiler-phase "Assembly"
(if (zero? count) " iteration." " iterations.")))))))))
(define (phase/info-generation-2 pathname)
+ (info-generation-2 pathname set-compiled-code-block/debugging-info!))
+
+(define (info-generation-2 pathname set-debugging-info!)
(compiler-phase "Debugging Information Generation"
(lambda ()
- (set-compiled-code-block/debugging-info!
+ (set-debugging-info!
*code-vector*
(let ((info
(info-generation-phase-3
projects / mit-scheme.git / commitdiff