From 430adc6a531ac0c0aa5da64e1bcbaca7c66f0be9 Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Wed, 17 May 1989 20:44:56 +0000 Subject: [PATCH] Initial revision --- v7/src/compiler/base/crsend.scm | 170 ++++++++++++++++++++++++++++++++ v7/src/compiler/base/crstop.scm | 153 ++++++++++++++++++++++++++++ 2 files changed, 323 insertions(+) create mode 100644 v7/src/compiler/base/crsend.scm create mode 100644 v7/src/compiler/base/crstop.scm diff --git a/v7/src/compiler/base/crsend.scm b/v7/src/compiler/base/crsend.scm new file mode 100644 index 000000000..ab1d7cabc --- /dev/null +++ b/v7/src/compiler/base/crsend.scm @@ -0,0 +1,170 @@ +#| -*-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 $ +$MC68020-Header: toplev.scm,v 4.16 89/04/26 05:09:52 GMT cph Exp $ + +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 +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; 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 + +(declare (usual-integrations)) + +(define-macro (last-reference name) + (let ((x (generate-uninterned-symbol))) + `(IF COMPILER:PRESERVE-DATA-STRUCTURES? + ,name + (LET ((,x ,name)) + (SET! ,name) + ,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))))) + +(define (cross-compile-scode-end cross-compilation) + (in-compiler + (lambda () + (cross-link-end cross-compilation) + compiler:expression))) + +(define-structure (cc-vector (constructor cc-vector/make) + (conc-name cc-vector/)) + (code-vector false read-only true) + (entry-label false read-only true) + (entry-points false read-only true) + (label-bindings false read-only true) + (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! *ic-procedure-headers* (cc-vector/ic-procedure-headers cc-vector)) + (phase/link)) + +(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*)))) + +(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)))) + +;;;; 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 *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*)) + (thunk))) + +(define (compiler-phase name thunk) + (newline) + (display name) + (thunk)) + +(define (compiler-fasload file) + (fasload file)) \ No newline at end of file diff --git a/v7/src/compiler/base/crstop.scm b/v7/src/compiler/base/crstop.scm new file mode 100644 index 000000000..50df4c051 --- /dev/null +++ b/v7/src/compiler/base/crstop.scm @@ -0,0 +1,153 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crstop.scm,v 1.1 1989/05/17 20:44:27 jinx 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 + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Cross Compiler Top Level. +;;; This code shares and should be merged with toplev.scm. +;;; Many of the procedures only differ in the default extensions. + +(declare (usual-integrations)) + +(define-macro (last-reference name) + (let ((x (generate-uninterned-symbol))) + `(IF COMPILER:PRESERVE-DATA-STRUCTURES? + ,name + (LET ((,x ,name)) + (SET! ,name) + ,x)))) + +(define (cross-compile-bin-file input-string #!optional output-string) + (let ((input-default + (make-pathname false false false false "bin" 'NEWEST)) + (output-default + (make-pathname false false false false "bits.x" false))) + (compiler-pathnames + input-string + (if (not (default-object? output-string)) + output-string + (merge-pathnames output-default + (pathname->input-truename + (merge-pathnames (->pathname input-string) + input-default)))) + input-default + (lambda (input-pathname output-pathname) + (cross-compile-scode (compiler-fasload input-pathname) + (and compiler:generate-rtl-files? + (pathname-new-type output-pathname "brtl.x")) + (pathname-new-type output-pathname "binf.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) + (fasdump (cross-compile-scode-end (compiler-fasload input-pathname)) + output-pathname)))) + +(define (cross-compile-scode-end cross-compilation) + (in-compiler + (lambda () + (cross-link-end cross-compilation) + compiler:expression))) + +;; This should be merged with compile-scode + +(define (cross-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) + (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)) + ;; Here is were this procedure differs from compile-scode + (phase/cross-link) + compiler:expression)))) + +(define-structure (cc-vector (constructor cc-vector/make) + (conc-name cc-vector/)) + (code-vector false read-only true) + (entry-label false read-only true) + (entry-points false read-only true) + (label-bindings false read-only true) + (ic-procedure-headers false read-only true)) + +(define (phase/cross-link) + (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*))) + 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)) + (phase/link)) \ No newline at end of file -- 2.25.1