Resurrect the cross compiler.

diff --git a/v7/src/compiler/base/asstop.scm b/v7/src/compiler/base/asstop.scm
index 4e8bf9df5d6732b79a05b316b87daa3b5e55c316..4a3d5d1a9946552b44f73cdee21da554226fd8cb 100644 (file)
--- 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.
 \f
 ;;;; 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 85bedddf03940ed878b211eef500ded64f111409..2c280533b4b21bc4af5de191ded96d08812f0577 100644 (file)
--- 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))
 \f
-(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*)))
-\f
-;;; 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*)))))
-\f
-(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 619ede5718e6f010a38e4dd148f6e5fd5a468c9a..38ee985828a1f0efef529bb293dfa624fa62c32b 100644 (file)
--- 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"))
 \f
 (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)))))))
 \f
 (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 945604ca1d3dc5a84722d63b2e679d9682d89b07..8ac8f81d4f72192bdd8fca66d783e7beca4fec01 100644 (file)
--- 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 b05d9cfe77b4bfcd4bb6bb70ec90d7ef09f23b8c..8228ef63d2cc7f048d0299e201443b0914974d8e 100644 (file)
--- 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.
 \f
 ;;;; 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 793f42dcdf29f14b7e91a5ab57da795891b2945b..cc7ec95d7bdcd21ba5244d408d299b973b4cc033 100644 (file)
--- 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 a8b26ed8d17ef708329e5b46e0adc65a665a8a6c..26bff5c212ab89695273df2593bdf658a04f06c2 100755 (executable)
--- 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 18bd51e661fd98f0548e545146869dc004a55a30..5b017a245fb0c2fb443c48742b98bb88c4547e13 100644 (file)
--- 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