From 07791f119654e532a9ae67c3369d709692d3d041 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 14 Jun 2007 17:39:26 +0000 Subject: [PATCH] Rename top-level procedures to FINISH-CROSS-COMPILATION:foo, and add new procedure FINISH-CROSS-COMPILATION:DIRECTORY. Rewrite to update and style. --- v7/src/compiler/base/crsend.scm | 193 ++++++++++++++++---------------- 1 file changed, 95 insertions(+), 98 deletions(-) diff --git a/v7/src/compiler/base/crsend.scm b/v7/src/compiler/base/crsend.scm index f328c699f..bd8604582 100644 --- a/v7/src/compiler/base/crsend.scm +++ b/v7/src/compiler/base/crsend.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: crsend.scm,v 1.17 2007/01/05 21:19:20 cph Exp $ +$Id: crsend.scm,v 1.18 2007/06/14 17:39:26 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -25,54 +25,47 @@ USA. |# -;;;; 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 +;;;; Finish cross-compilation process + +;;; This program takes the output of the cross compiler (.moc files) +;;; and converts it into its final form. It must be run on the target +;;; machine. It can be loaded and run without the rest of the +;;; compiler. (declare (usual-integrations)) -(define-syntax ucode-primitive - (sc-macro-transformer - (lambda (form environment) - environment - (apply make-primitive-procedure (cdr form))))) - -(define-syntax ucode-type - (sc-macro-transformer - (lambda (form environment) - environment - (apply microcode-type (cdr form))))) - -(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 "moc" 'NEWEST) - (lambda (input-pathname output-pathname) - output-pathname ;ignore - (cross-compile-scode-end (fasload input-pathname))))) - -(define (compiler-pathnames input-string output-string default transform) - (let ((kernel - (lambda (input-string) - (let ((input-pathname (merge-pathnames input-string default))) - (let ((output-pathname - (let ((output-pathname - (pathname-new-type input-pathname "com"))) - (if output-string - (merge-pathnames output-string output-pathname) - output-pathname)))) - (newline) - (write-string "Compile File: ") - (write (enough-namestring input-pathname)) - (write-string " => ") - (write (enough-namestring output-pathname)) - (fasdump (transform input-pathname output-pathname) - output-pathname)))))) - (if (pair? input-string) - (for-each kernel input-string) - (kernel input-string)))) - -(define (cross-compile-scode-end cross-compilation) +(define (finish-cross-compilation:directory directory #!optional force?) + (let ((force? (if (default-object? force?) #f force?))) + (let loop ((directory directory)) + (for-each (lambda (pathname) + (cond ((file-directory? pathname) + (if (not (let ((ns (file-namestring pathname))) + (or (string=? ns ".") + (string=? ns "..")))) + (loop pathname))) + ((let ((t (pathname-type pathname))) + (and (string? t) + (string=? t "moc"))) + (finish-cross-compilation:file pathname force?)))) + (directory-read (pathname-as-directory directory)))))) + +(define (finish-cross-compilation:file input-file #!optional force?) + (let* ((input-file (pathname-default-type input-file "moc")) + (output-file (pathname-new-type input-file "com"))) + (if (or (if (default-object? force?) #t force?) + (file-modification-time " port) + (write (enough-namestring output-file) port)) + (lambda () + (fasdump (finish-cross-compilation:scode (fasload input-file #t)) + output-file + #t)))))) + +(define (finish-cross-compilation:scode cross-compilation) (let ((compile-by-procedures? (vector-ref cross-compilation 0)) (expression (cross-link-end (vector-ref cross-compilation 1))) (others (map cross-link-end (vector-ref cross-compilation 2)))) @@ -92,39 +85,22 @@ USA. 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 (type 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 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))) + (if (compiled-code-block? code-vector) + code-vector + (begin + (guarantee-vector code-vector #f) + (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))) object))) (define (cross-link/process-code-vector code-vector cc-vector) @@ -145,39 +121,60 @@ USA. (let ((label->expression (lambda (label) (cdr (or (assq label bindings) - (error "Label not defined as entry point" label)))))) + (error "Label not defined as entry point:" label)))))) (let ((expression (label->expression (cc-vector/entry-label cc-vector)))) (for-each (lambda (entry) (set-lambda-body! (car entry) (label->expression (cdr entry)))) (cc-vector/ic-procedure-headers cc-vector)) expression)))) - + (define (cross-link/finish-assembly 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))))) + (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 (+ (length objects) bl 1)))) (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))) - + ;; After header just inserted. + (write-bits! output-block (* scheme-object-width 2) code-block) + (insert-objects! output-block objects (+ bl 1)) + (object-new-type (ucode-type compiled-code-block) output-block))) + (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 + (let ((end (vector-length v))) + (do ((objects objects (cdr objects)) + (index where (fix:+ index 1))) + ((not (fix:< index end)) unspecific) + (vector-set! v index (cadar objects))))) + +(define-structure (cc-code-block (type vector) + (conc-name cc-code-block/)) + (debugging-info #f read-only #f) + (bit-string #f read-only #t) + (objects #f read-only #t) + (object-width #f read-only #t)) + +(define-structure (cc-vector (type vector) + (constructor cc-vector/make) + (conc-name cc-vector/)) + (code-vector #f read-only #t) + (entry-label #f read-only #t) + (entry-points #f read-only #t) + (label-bindings #f read-only #t) + (ic-procedure-headers #f read-only #t)) + +(define-syntax ucode-primitive + (sc-macro-transformer + (lambda (form environment) + environment + (apply make-primitive-procedure (cdr form))))) + +(define-syntax ucode-type + (sc-macro-transformer + (lambda (form environment) + environment + (apply microcode-type (cdr form))))) \ No newline at end of file -- 2.25.1