From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 14 Jun 2007 17:39:26 +0000 (+0000)
Subject: Rename top-level procedures to FINISH-CROSS-COMPILATION:foo, and add
X-Git-Tag: 20090517-FFI~530
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=07791f119654e532a9ae67c3369d709692d3d041;p=mit-scheme.git

Rename top-level procedures to FINISH-CROSS-COMPILATION:foo, and add
new procedure FINISH-CROSS-COMPILATION:DIRECTORY.  Rewrite to update
and style.
---

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<? output-file input-file))
+	(with-notification
+	    (lambda (port)
+	      (write-string "Compiling file: " port)
+	      (write (enough-namestring input-file) port)
+	      (write-string " => " 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