From 17a6ed3e8c2d21392ef381acbc8c64e5eddd0777 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 13 Jun 2007 13:35:38 +0000
Subject: [PATCH] Resurrect the cross compiler.

---
 v7/src/compiler/base/asstop.scm            |   5 +-
 v7/src/compiler/base/crstop.scm            | 127 +++++----------------
 v7/src/compiler/base/toplev.scm            | 100 ++++++++--------
 v7/src/compiler/machines/C/compiler.pkg    |   9 +-
 v7/src/compiler/machines/C/ctop.scm        |   8 +-
 v7/src/compiler/machines/i386/compiler.pkg |   6 +-
 v7/src/etc/Clean.sh                        |   4 +-
 v7/src/sf/butils.scm                       |  31 ++---
 8 files changed, 104 insertions(+), 186 deletions(-)

diff --git a/v7/src/compiler/base/asstop.scm b/v7/src/compiler/base/asstop.scm
index 4e8bf9df5..4a3d5d1a9 100644
--- a/v7/src/compiler/base/asstop.scm
+++ b/v7/src/compiler/base/asstop.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: asstop.scm,v 1.19 2007/04/14 05:58:59 cph Exp $
+$Id: asstop.scm,v 1.20 2007/06/13 13:33:31 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -32,7 +32,8 @@ USA.
 
 ;;;; Exports to the compiler
 
-(define compiled-output-extension "com")
+(define (compiler:compiled-code-pathname-type)
+  (if compiler:cross-compiling? "moc" "com"))
 
 (define (compiler-file-output object pathname)
   (fasdump object pathname #t))
diff --git a/v7/src/compiler/base/crstop.scm b/v7/src/compiler/base/crstop.scm
index 85bedddf0..2c280533b 100644
--- a/v7/src/compiler/base/crstop.scm
+++ b/v7/src/compiler/base/crstop.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: crstop.scm,v 1.17 2007/01/05 21:19:20 cph Exp $
+$Id: crstop.scm,v 1.18 2007/06/13 13:33:37 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -31,36 +31,23 @@ USA.
 
 (declare (usual-integrations))
 
-(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 "moc" false)))
-    (compiler-pathnames
-     input-string
-     (if (not (default-object? output-string))
-	 output-string
-	 (merge-pathnames output-default
-			  (merge-pathnames input-string input-default)))
-     input-default
-     (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)
-	       (cross-compile-scode (compiler-fasload input-pathname)
-				    (pathname-new-type output-pathname
-						       "fni")
-				    rtl-output-port
-				    lap-output-port)))))))))
+(define (in-cross-compiler thunk)
+  (fluid-let ((compiler:compile-by-procedures? #f)
+	      (compiler:dump-info-file compiler:dump-inf-file))
+    (in-compiler thunk)))
+
+(define (cross-assemble&link info-output-pathname)
+  (phase/assemble)
+  (if info-output-pathname
+      (cross-compiler-phase/info-generation-2 info-output-pathname))
+  (cross-compiler-phase/link)
+  *result*)
 
 (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)
+   (make-pathname #f #f #f #f "moc" 'NEWEST)
    (lambda (input-pathname output-pathname)
      output-pathname			; ignored
      (cross-compile-scode-end (compiler-fasload input-pathname)))))
@@ -70,72 +57,6 @@ USA.
    (lambda ()
      (cross-link-end cross-compilation)
      *result*)))
-
-;;; This should be merged with compile-scode
-
-(define (cross-compile-scode scode
-			     #!optional
-			     info-output-pathname
-			     rtl-output-port
-			     lap-output-port
-			     wrapper)
-  (let ((info-output-pathname
-	 (if (default-object? info-output-pathname)
-	     false
-	     info-output-pathname))
-	(rtl-output-port
-	 (if (default-object? rtl-output-port) false rtl-output-port))
-	(lap-output-port
-	 (if (default-object? lap-output-port) false 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)
-		     *info-output-filename*))
-		(*rtl-output-port* rtl-output-port)
-		(*lap-output-port* lap-output-port))
-      ((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-port
-	     (phase/rtl-file-output rtl-output-port))
-	 (phase/lap-generation)
-	 (phase/lap-linearization)
-	 (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
-	     (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 (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-compiler-phase/info-generation-2 pathname)
   (info-generation-2 pathname set-cc-code-block/debugging-info!))
@@ -152,10 +73,18 @@ USA.
 			   (last-reference *ic-procedure-headers*)))
      unspecific)))
 
-(define (cross-link-end cc-vector)
-  (set! *code-vector* (cc-vector/code-vector cc-vector))
-  (set! *entry-label* (cc-vector/entry-label cc-vector))
-  (set! *entry-points* (cc-vector/entry-points cc-vector))
-  (set! *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
+(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))
\ No newline at end of file
diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm
index 619ede571..38ee98582 100644
--- a/v7/src/compiler/base/toplev.scm
+++ b/v7/src/compiler/base/toplev.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: toplev.scm,v 4.74 2007/06/06 19:14:55 cph Exp $
+$Id: toplev.scm,v 4.75 2007/06/13 13:33:43 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -40,8 +40,9 @@ USA.
 (let ((scm-pathname (lambda (path) (pathname-new-type path "scm")))
       (bin-pathname (lambda (path) (pathname-new-type path "bin")))
       (ext-pathname (lambda (path) (pathname-new-type path "ext")))
-      (com-pathname (lambda (path)
-		      (pathname-new-type path compiled-output-extension))))
+      (com-pathname
+       (lambda (path)
+	 (pathname-new-type path (compiler:compiled-code-pathname-type)))))
 
   (define (process-file input-file output-file dependencies processor)
     (let ((doit (lambda () (processor input-file output-file dependencies))))
@@ -128,41 +129,37 @@ USA.
   (apply compile-bin-file input rest))
 
 (define (compile-bin-file input-string #!optional output-string)
-  (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 #f #f #f #f "bin" 'NEWEST)
-	 (lambda (input-pathname output-pathname)
-	   (fluid-let ((*compiler-input-pathname*
-			(merge-pathnames input-pathname))
-		       (*compiler-output-pathname*
-			(merge-pathnames output-pathname)))
-	     (let ((scode (compiler-fasload input-pathname)))
-	       (if (and (scode/constant? scode)
-			(not compiler:compile-data-files-as-expressions?))
-		   (compile-data-from-file scode 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)
-			 (fluid-let ((*debugging-key*
-				      (random-byte-vector 32)))
-			   (compile-scode/internal
-			    scode
-			    (pathname-new-type output-pathname "inf")
-			    rtl-output-port
-			    lap-output-port)))))))))))
-	unspecific)))
+  (compiler-pathnames
+   input-string
+   (and (not (default-object? output-string)) output-string)
+   (make-pathname #f #f #f #f "bin" 'NEWEST)
+   (lambda (input-pathname output-pathname)
+     (fluid-let ((*compiler-input-pathname*
+		  (merge-pathnames input-pathname))
+		 (*compiler-output-pathname*
+		  (merge-pathnames output-pathname)))
+       (let ((scode (compiler-fasload input-pathname)))
+	 (if (and (scode/constant? scode)
+		  (not compiler:compile-data-files-as-expressions?))
+	     (compile-data-from-file scode 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)
+		   (fluid-let ((*debugging-key*
+				(random-byte-vector 32)))
+		     (compile-scode/internal
+		      scode
+		      (pathname-new-type
+		       output-pathname
+		       (compiler:compiled-inf-pathname-type))
+		      rtl-output-port
+		      lap-output-port)))))))))))
+  unspecific)
 
 (define *debugging-key*)
 (define *compiler-input-pathname*)
@@ -172,6 +169,9 @@ USA.
   (if open?
       (call-with-output-file pathname receiver)
       (receiver #f)))
+
+(define (compiler:compiled-inf-pathname-type)
+  (if compiler:cross-compiling? "fni" "inf"))
 
 (define (compiler-pathnames input-string output-string default transform)
   (let* ((core
@@ -179,8 +179,9 @@ USA.
 	    (let ((input-pathname (merge-pathnames input-string default)))
 	      (let ((output-pathname
 		     (let ((output-pathname
-			    (pathname-new-type input-pathname
-					       compiled-output-extension)))
+			    (pathname-new-type
+			     input-pathname
+			     (compiler:compiled-code-pathname-type))))
 		       (if output-string
 			   (merge-pathnames output-string output-pathname)
 			   output-pathname))))
@@ -536,7 +537,11 @@ USA.
 	(lap-output-port
 	 (if (default-object? lap-output-port) #f lap-output-port))
 	(wrapper
-	 (if (default-object? wrapper) in-compiler wrapper)))
+	 (if (default-object? wrapper)
+	     (if compiler:cross-compiling?
+		 in-cross-compiler
+		 in-compiler)
+	     wrapper)))
     (fluid-let ((*info-output-filename*
 		 (if (pathname? info-output-pathname)
 		     info-output-pathname
@@ -557,19 +562,16 @@ USA.
 	 (phase/fg-generation)
 	 (phase/fg-optimization)
 	 (phase/rtl-generation)
-	 #|
-	 ;; Current info-generation keeps state in-core.
-	 (if info-output-pathname
-	     (phase/info-generation-1 info-output-pathname))
-	 |#
 	 (phase/rtl-optimization)
 	 (if rtl-output-port
-	     (phase/rtl-file-output scode rtl-output-port))
+	     (phase/rtl-file-output rtl-output-port))
 	 (phase/lap-generation)
 	 (phase/lap-linearization)
 	 (if lap-output-port
-	     (phase/lap-file-output scode lap-output-port))
-	 (assemble&link info-output-pathname))))))
+	     (phase/lap-file-output lap-output-port))
+	 (if compiler:cross-compiling?
+	     (cross-assemble&link info-output-pathname)
+	     (assemble&link info-output-pathname)))))))
 
 (define (compiler-phase name thunk)
   (if compiler:show-phases?
diff --git a/v7/src/compiler/machines/C/compiler.pkg b/v7/src/compiler/machines/C/compiler.pkg
index 945604ca1..8ac8f81d4 100644
--- a/v7/src/compiler/machines/C/compiler.pkg
+++ b/v7/src/compiler/machines/C/compiler.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: compiler.pkg,v 1.28 2007/06/06 19:42:38 cph Exp $
+$Id: compiler.pkg,v 1.29 2007/06/13 13:33:49 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -244,12 +244,9 @@ USA.
 	  compile-file:sf-only?
 	  compile-procedure
 	  compile-scode
+	  compiler:compiled-code-pathname-type
 	  compiler:invoke-c-compiler?
-	  compiler:reset!
-	  ;; cross-compile-bin-file
-	  ;; cross-compile-bin-file-end
-	  ;; lap->code
-	  )
+	  compiler:reset!)
   (export (compiler)
 	  *compiler-input-pathname*
 	  *compiler-output-pathname*
diff --git a/v7/src/compiler/machines/C/ctop.scm b/v7/src/compiler/machines/C/ctop.scm
index b05d9cfe7..8228ef63d 100644
--- a/v7/src/compiler/machines/C/ctop.scm
+++ b/v7/src/compiler/machines/C/ctop.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: ctop.scm,v 1.30 2007/06/06 19:42:38 cph Exp $
+$Id: ctop.scm,v 1.31 2007/06/13 13:33:55 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -32,7 +32,7 @@ USA.
 
 ;;;; Exports to the compiler
 
-(define compiled-output-extension "c")
+(define (compiler:compiled-code-pathname-type) "c")
 (define compiler:invoke-c-compiler? #t)
 (define compiler:invoke-verbose? #t)
 
@@ -65,10 +65,6 @@ USA.
 				      "inf")))
 	(action))))
 
-(define (cross-compile-bin-file input . more)
-  input more				; ignored
-  (error "cross-compile-bin-file: Meaningless"))
-
 (define (optimize-linear-lap lap-program)
   lap-program)
 
diff --git a/v7/src/compiler/machines/i386/compiler.pkg b/v7/src/compiler/machines/i386/compiler.pkg
index 793f42dcd..cc7ec95d7 100644
--- a/v7/src/compiler/machines/i386/compiler.pkg
+++ b/v7/src/compiler/machines/i386/compiler.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: compiler.pkg,v 1.34 2007/01/05 21:19:21 cph Exp $
+$Id: compiler.pkg,v 1.35 2007/06/13 13:34:01 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -74,6 +74,7 @@ USA.
 	  compiler:coalescing-constant-warnings?
 	  compiler:code-compression?
 	  compiler:compile-by-procedures?
+	  compiler:cross-compiling?
 	  compiler:cse?
 	  compiler:default-top-level-declarations
 	  compiler:enable-integration-declarations?
@@ -243,9 +244,8 @@ USA.
 	  compile-file:sf-only?
 	  compile-procedure
 	  compile-scode
+	  compiler:compiled-code-pathname-type
 	  compiler:reset!
-	  cross-compile-bin-file
-	  cross-compile-bin-file-end
 	  lap->code)
   (export (compiler)
 	  canonicalize-label-name)
diff --git a/v7/src/etc/Clean.sh b/v7/src/etc/Clean.sh
index a8b26ed8d..26bff5c21 100755
--- a/v7/src/etc/Clean.sh
+++ b/v7/src/etc/Clean.sh
@@ -1,6 +1,6 @@
 #!/bin/sh
 #
-# $Id: Clean.sh,v 1.23 2007/05/14 16:50:44 cph Exp $
+# $Id: Clean.sh,v 1.24 2007/06/13 13:35:38 cph Exp $
 #
 # Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
 #     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
@@ -91,7 +91,7 @@ for KEYWORD in ${KEYWORDS}; do
 	maybe_rm *.bin *.ext
 	;;
     rm-com)
-	maybe_rm *.com *.bci *.o *.so *.sl *.dylib
+	maybe_rm *.com *.bci *.moc *.fni *.o *.so *.sl *.dylib
 	;;
     rm-pkg)
 	maybe_rm *-unx.crf *-unx.fre *-unx.pkd
diff --git a/v7/src/sf/butils.scm b/v7/src/sf/butils.scm
index 18bd51e66..5b017a245 100644
--- a/v7/src/sf/butils.scm
+++ b/v7/src/sf/butils.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: butils.scm,v 4.16 2007/01/05 21:19:29 cph Exp $
+$Id: butils.scm,v 4.17 2007/06/13 13:34:07 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -70,12 +70,7 @@ USA.
   (directory-processor
    "bin"
    (lambda ()
-     (if (environment-lookup (->environment '(compiler))
-			     'compiler:cross-compiling?)
-	 "moc"
-	 (environment-lookup (->environment '(compiler top-level))
-						 
-			     'compiled-output-extension)))
+     (compiler:compiled-code-pathname-type))
    (lambda (pathname output-directory)
      (compile-bin-file pathname output-directory))))
 
@@ -93,18 +88,16 @@ USA.
 (define (sf-conditionally filename #!optional echo-up-to-date?)
   (let ((kernel
 	 (lambda (filename)
-	   (call-with-values
-	       (lambda () (sf/pathname-defaulting filename #f #f))
-	     (lambda (input output spec)
-	       spec
-	       (cond ((not (file-modification-time<=? input output))
-		      (sf filename))
-		     ((and (not (default-object? echo-up-to-date?))
-			   echo-up-to-date?)
-		      (newline)
-		      (write-string "Syntax file: ")
-		      (write filename)
-		      (write-string " is up to date"))))))))
+	   (receive (input output spec) (sf/pathname-defaulting filename #f #f)
+	     spec
+	     (cond ((not (file-modification-time<=? input output))
+		    (sf filename))
+		   ((and (not (default-object? echo-up-to-date?))
+			 echo-up-to-date?)
+		    (newline)
+		    (write-string "Syntax file: ")
+		    (write filename)
+		    (write-string " is up to date")))))))
     (if (pair? filename)
 	(for-each kernel filename)
 	(kernel filename))))
\ No newline at end of file
-- 
2.25.1