From bd2ac07d442fc90c5b99c915041ddd3fbb8a463e Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Fri, 12 Jun 1992 01:43:44 +0000 Subject: [PATCH] Change cross-compiler to dump a bit-string and a bunch of objects instead of a compiled code block. This allows cross-compilation to machines with a different word size. --- v7/src/compiler/back/bittop.scm | 45 +++++++++-------- v7/src/compiler/base/crsend.scm | 89 ++++++++++++++++++++++++++------- v7/src/compiler/base/crstop.scm | 27 +++++++--- v7/src/compiler/base/make.scm | 6 +-- v7/src/compiler/base/switch.scm | 5 +- v7/src/compiler/base/toplev.scm | 53 ++++++++++++-------- 6 files changed, 154 insertions(+), 71 deletions(-) diff --git a/v7/src/compiler/back/bittop.scm b/v7/src/compiler/back/bittop.scm index e4bd69dc5..8fccebd95 100644 --- a/v7/src/compiler/back/bittop.scm +++ b/v7/src/compiler/back/bittop.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -88,7 +88,7 @@ MIT in each case. |# (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*))))))) @@ -130,24 +130,27 @@ MIT in each case. |# 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)) diff --git a/v7/src/compiler/base/crsend.scm b/v7/src/compiler/base/crsend.scm index ee4e0401e..d7a7e13bb 100644 --- a/v7/src/compiler/base/crsend.scm +++ b/v7/src/compiler/base/crsend.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -47,7 +47,7 @@ MIT in each case. |# (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 @@ -62,18 +62,11 @@ MIT in each case. |# (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))) @@ -94,6 +87,13 @@ MIT in each case. |# all-blocks))) expression)))) +(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) @@ -102,10 +102,28 @@ MIT in each case. |# (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 @@ -113,9 +131,12 @@ MIT in each case. |# (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))) @@ -131,6 +152,38 @@ MIT in each case. |# (label->expression (cdr entry)))) (cc-vector/ic-procedure-headers cc-vector)) expression)))) + +(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 diff --git a/v7/src/compiler/base/crstop.scm b/v7/src/compiler/base/crstop.scm index 1c4b01f9d..3ce36cc78 100644 --- a/v7/src/compiler/base/crstop.scm +++ b/v7/src/compiler/base/crstop.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -67,7 +67,7 @@ MIT in each case. |# (lambda (lap-output-port) (cross-compile-scode (compiler-fasload input-pathname) (pathname-new-type output-pathname - "fnib") + "fni") rtl-output-port lap-output-port))))))))) @@ -105,6 +105,8 @@ MIT in each case. |# (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) @@ -127,12 +129,20 @@ MIT in each case. |# (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*))))) +(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) @@ -141,7 +151,10 @@ MIT in each case. |# (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 () diff --git a/v7/src/compiler/base/make.scm b/v7/src/compiler/base/make.scm index be2ecdce8..944c3ec17 100644 --- a/v7/src/compiler/base/make.scm +++ b/v7/src/compiler/base/make.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -46,5 +46,5 @@ MIT in each case. |# (initialize-package! '(COMPILER DECLARATIONS))) (add-system! (make-system (string-append "Liar (" architecture-name ")") - 4 90 + 4 91 '()))) \ No newline at end of file diff --git a/v7/src/compiler/base/switch.scm b/v7/src/compiler/base/switch.scm index 77e08bcbd..31ad280d4 100644 --- a/v7/src/compiler/base/switch.scm +++ b/v7/src/compiler/base/switch.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -63,6 +63,7 @@ MIT in each case. |# (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 diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm index cebb2e646..5f91e95dc 100644 --- a/v7/src/compiler/base/toplev.scm +++ b/v7/src/compiler/base/toplev.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.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 @@ -56,22 +56,30 @@ MIT in each case. |# (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? @@ -968,7 +976,8 @@ MIT in each case. |# (if (not (zero? *recursive-compilation-number*)) (begin (write-char #\page port) - (newline port)))))) + (newline port))) + (output-port/flush-output port)))) (define (phase/lap-generation) (compiler-phase "LAP Generation" @@ -1056,7 +1065,8 @@ MIT in each case. |# (if (not (zero? *recursive-compilation-number*)) (begin (write-char #\page) - (newline))))))))) + (newline))) + (output-port/flush-output port))))))) (define (phase/assemble) (compiler-phase "Assembly" @@ -1077,9 +1087,12 @@ MIT in each case. |# (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 -- 2.25.1