From: Taylor R Campbell <campbell@mumble.net>
Date: Tue, 11 Dec 2018 15:52:07 +0000 (+0000)
Subject: Teach cross-SF/CREF to dump/load in .nib, .txe, .dkp.
X-Git-Tag: mit-scheme-pucked-10.1.9~3^2~35^2~41
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=dc21a9094a5107ca7e2c8645cb5ebef8da70dd19;p=mit-scheme.git

Teach cross-SF/CREF to dump/load in .nib, .txe, .dkp.

These correspond to .bin, .ext, .pkd.  LOAD-OPTION still loads from
.bin, .ext, .pkd (and .com) for libraries that are installed and are
not macro definitions of subsystems being cross-compiled.

This backwards suffix business is getting a little out of hand.
Possible partial alternatives:

- .xbin/.xext/.xpkd

- invent a static linker in the toolchain that can run on the cross
  host rather than using make.scm and disk-save in the cross target

- devise a portable fasload that sf/cref can use in the cross host

- use a machine-independent file format for .bin/.ext/.pkd
---

diff --git a/src/Makefile.in b/src/Makefile.in
index 9d16487a6..6f428af8a 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -72,10 +72,14 @@ AUXDIR_NAME = @AUXDIR_NAME@
 AUXDIR = @AUXDIR@
 
 @IF_CROSS@COMPILER_SETTINGS_CROSS = (set! compiler:cross-compiling? true)
+@IF_CROSS@SF_SETTINGS_CROSS = \
+@IF_CROSS@	(set! sf/cross-compiling? true) \
+@IF_CROSS@	(set! package/cross-compiling? true)
 @IF_LIARC@COMPILER_SETTINGS_LIARC = (set! compiler:invoke-c-compiler? false)
 HOST_COMPILER_HEAP = @HOST_COMPILER_HEAP@
 
 HOST_COMPILER_SETTINGS = \
+	$(SF_SETTINGS_CROSS) \
 	$(COMPILER_SETTINGS_CROSS) \
 	$(COMPILER_SETTINGS_LIARC)
 
@@ -242,8 +246,10 @@ all-compiler: compile-compiler
 syntax-compiler: compile-sf
 @IF_SVM_COMPILER@syntax-compiler: compiler/machines/svm/svm1-defns.h
 	(echo '(with-working-directory-pathname "compiler"' && \
-	 echo '  (lambda () (load "compiler.sf")))') \
-	| $(HOST_RUNTIME_ONLY)
+	 echo '  (lambda ()' && \
+	 echo '    $(SF_SETTINGS_CROSS)' && \
+	 echo '    (load "compiler.sf")))') \
+	| $(HOST_RUNTIME_ONLY) --eval '(load-option (quote SF))'
 
 .PHONY: compile-compiler
 compile-compiler: compile-compiler-back
diff --git a/src/compiler/base/toplev.scm b/src/compiler/base/toplev.scm
index 81bd2e749..23b293f88 100644
--- a/src/compiler/base/toplev.scm
+++ b/src/compiler/base/toplev.scm
@@ -38,7 +38,9 @@ USA.
 (define compiler:compile-data-files-as-expressions? #t)
 (define compile-file)
 (let ((scm-pathname (lambda (path) (pathname-new-type path "scm")))
-      (bin-pathname (lambda (path) (pathname-new-type path "bin")))
+      (bin-pathname
+       (lambda (path)
+	 (pathname-new-type path (if sf/cross-compiling? "nib" "bin"))))
       (ext-pathname (lambda (path) (pathname-default-type path "ext")))
       (ext-pathname? (lambda (path) (equal? (pathname-type path) "ext")))
       (com-pathname
@@ -133,7 +135,7 @@ USA.
   (compiler-pathnames
    input-string
    (and (not (default-object? output-string)) output-string)
-   (make-pathname #f #f #f #f "bin" 'NEWEST)
+   (make-pathname #f #f #f #f (if sf/cross-compiling? "nib" "bin") 'NEWEST)
    (lambda (input-pathname output-pathname)
      (fluid-let ((*compiler-input-pathname*
 		  (merge-pathnames input-pathname))
@@ -277,13 +279,14 @@ USA.
 
 ;;;; Alternate Entry Points
 
-(define compile-directory
-  (directory-processor
-   "bin"
-   (lambda ()
-     (compiler:compiled-code-pathname-type))
-   (lambda (pathname output-directory)
-     (compile-bin-file pathname output-directory))))
+(define (compile-directory input-directory #!optional output-directory force?)
+  ((directory-processor
+    (if sf/cross-compiling? "nib" "bin")
+    (lambda ()
+      (compiler:compiled-code-pathname-type))
+    (lambda (pathname output-directory)
+      (compile-bin-file pathname output-directory)))
+   input-directory output-directory force?))
 
 (define (compile-scode scode #!optional keep-debugging-info?)
   (compiler-output->compiled-expression
diff --git a/src/compiler/machines/C/compiler.sf b/src/compiler/machines/C/compiler.sf
index 5503a4e10..e4c187227 100644
--- a/src/compiler/machines/C/compiler.sf
+++ b/src/compiler/machines/C/compiler.sf
@@ -44,7 +44,10 @@ USA.
 	     (fluid-let ((sf/default-syntax-table (->environment package)))
 	       (sf-conditionally files))
 	     (for-each (lambda (file)
-			 (load (string-append file ".bin") package))
+			 (receive (scm bin spec)
+				  (sf/pathname-defaulting file #f #f)
+			   scm spec
+			   (load bin package)))
 		       files))))
       (load-option 'hash-table)
       (fresh-line)
diff --git a/src/compiler/machines/C/decls.scm b/src/compiler/machines/C/decls.scm
index d699401c1..06c561345 100644
--- a/src/compiler/machines/C/decls.scm
+++ b/src/compiler/machines/C/decls.scm
@@ -194,11 +194,14 @@ USA.
   (for-each
    (lambda (node)
      (let ((modification-time
-	    (let ((source (modification-time node "scm"))
-		  (binary (modification-time node "bin")))
-	      (if (not source)
-		  (error "Missing source file" (source-node/filename node)))
-	      (and binary (< source binary) binary))))
+	    (receive (scm bin spec)
+		     (sf/pathname-defaulting (source-node/pathname node) #f #f)
+	      spec
+	      (let ((source (file-modification-time scm))
+                    (binary (file-modification-time bin)))
+                (if (not source)
+                    (error "Missing source file" (source-node/filename node)))
+                (and binary (< source binary) binary)))))
      (set-source-node/modification-time! node modification-time)
      (if (not modification-time)
 	 (write-notification-line
@@ -320,10 +323,6 @@ USA.
 	  (lambda (declarations)
 	    (remove integration-declaration? declarations)))
       (source-node/declarations node)))))
-
-(define (modification-time node type)
-  (file-modification-time
-   (pathname-new-type (source-node/pathname node) type)))
 
 ;;;; Syntax dependencies
 
diff --git a/src/compiler/machines/i386/decls.scm b/src/compiler/machines/i386/decls.scm
index e836b3589..4542dfa99 100644
--- a/src/compiler/machines/i386/decls.scm
+++ b/src/compiler/machines/i386/decls.scm
@@ -190,11 +190,14 @@ USA.
   (for-each
    (lambda (node)
      (let ((modification-time
-	    (let ((source (modification-time node "scm"))
-		  (binary (modification-time node "bin")))
-	      (if (not source)
-		  (error "Missing source file" (source-node/filename node)))
-	      (and binary (< source binary) binary))))
+	    (receive (scm bin spec)
+		     (sf/pathname-defaulting (source-node/pathname node) #f #f)
+	      spec
+	      (let ((source (file-modification-time scm))
+		    (binary (file-modification-time bin)))
+		(if (not source)
+		    (error "Missing source file" (source-node/filename node)))
+		(and binary (< source binary) binary)))))
      (set-source-node/modification-time! node modification-time)
      (if (not modification-time)
 	 (write-notification-line
@@ -316,10 +319,6 @@ USA.
 	  (lambda (declarations)
 	    (remove integration-declaration? declarations)))
       (source-node/declarations node)))))
-
-(define (modification-time node type)
-  (file-modification-time
-   (pathname-new-type (source-node/pathname node) type)))
 
 ;;;; Syntax dependencies
 
diff --git a/src/compiler/machines/svm/compiler.sf b/src/compiler/machines/svm/compiler.sf
index 4c5db39af..c79ac6152 100644
--- a/src/compiler/machines/svm/compiler.sf
+++ b/src/compiler/machines/svm/compiler.sf
@@ -61,7 +61,10 @@ USA.
 			    (sf-conditionally file)))
 			files)
 	      (for-each (lambda (file)
-			  (load (pathname-new-type file "bin") (env file)))
+			  (receive (scm bin spec)
+				   (sf/pathname-defaulting file #f #f)
+			    scm spec
+			    (load bin (env file))))
 			files))))
 
       (fresh-line)
diff --git a/src/compiler/machines/svm/decls.scm b/src/compiler/machines/svm/decls.scm
index df6c9f5d1..670d707e4 100644
--- a/src/compiler/machines/svm/decls.scm
+++ b/src/compiler/machines/svm/decls.scm
@@ -198,11 +198,14 @@ USA.
   (for-each
    (lambda (node)
      (let ((modification-time
-	    (let ((source (modification-time node "scm"))
-		  (binary (modification-time node "bin")))
-	      (if (not source)
-		  (error "Missing source file" (source-node/filename node)))
-	      (and binary (< source binary) binary))))
+	    (receive (scm bin spec)
+		     (sf/pathname-defaulting (source-node/pathname node) #f #f)
+	      spec
+	      (let ((source (file-modification-time scm))
+		    (binary (file-modification-time bin)))
+		(if (not source)
+		    (error "Missing source file" (source-node/filename node)))
+		(and binary (< source binary) binary)))))
      (set-source-node/modification-time! node modification-time)
      (if (not modification-time)
 	 (write-notification-line
@@ -324,10 +327,6 @@ USA.
 	  (lambda (declarations)
 	    (remove integration-declaration? declarations)))
       (source-node/declarations node)))))
-
-(define (modification-time node type)
-  (file-modification-time
-   (pathname-new-type (source-node/pathname node) type)))
 
 ;;;; Integration Dependencies
 
diff --git a/src/compiler/machines/x86-64/decls.scm b/src/compiler/machines/x86-64/decls.scm
index 0c7f8f937..b867c9a90 100644
--- a/src/compiler/machines/x86-64/decls.scm
+++ b/src/compiler/machines/x86-64/decls.scm
@@ -190,11 +190,14 @@ USA.
   (for-each
    (lambda (node)
      (let ((modification-time
-	    (let ((source (modification-time node "scm"))
-		  (binary (modification-time node "bin")))
-	      (if (not source)
-		  (error "Missing source file" (source-node/filename node)))
-	      (and binary (< source binary) binary))))
+	    (receive (scm bin spec)
+		     (sf/pathname-defaulting (source-node/pathname node) #f #f)
+	      spec
+	      (let ((source (file-modification-time scm))
+		    (binary (file-modification-time bin)))
+		(if (not source)
+		    (error "Missing source file" (source-node/filename node)))
+		(and binary (< source binary) binary)))))
      (set-source-node/modification-time! node modification-time)
      (if (not modification-time)
 	 (write-notification-line
@@ -316,10 +319,6 @@ USA.
 	  (lambda (declarations)
 	    (remove integration-declaration? declarations)))
       (source-node/declarations node)))))
-
-(define (modification-time node type)
-  (file-modification-time
-   (pathname-new-type (source-node/pathname node) type)))
 
 ;;;; Syntax dependencies
 
diff --git a/src/cref/redpkg.scm b/src/cref/redpkg.scm
index 33aaa8369..aab90a81d 100644
--- a/src/cref/redpkg.scm
+++ b/src/cref/redpkg.scm
@@ -174,8 +174,9 @@ USA.
 (define (cache-file-analysis! pmodel caches pathname changes?)
   (let ((cache (analysis-cache/lookup caches pathname))
 	(full-pathname
-	 (merge-pathnames (pathname-new-type pathname "bin")
-			  (pmodel/pathname pmodel))))
+	 (merge-pathnames
+	  (pathname-new-type pathname (if sf/cross-compiling? "nib" "bin"))
+	  (pmodel/pathname pmodel))))
     (let ((time (file-modification-time full-pathname)))
       (if (not time)
 	  (error "unable to open file" full-pathname))
diff --git a/src/runtime/load.scm b/src/runtime/load.scm
index 280954cde..4df8cf428 100644
--- a/src/runtime/load.scm
+++ b/src/runtime/load.scm
@@ -184,7 +184,8 @@ USA.
 	      (or (try-fasl-file pathname)
 		  (try-fasl-file (pathname-new-type pathname "com"))
 		  (try-object-file (pathname-new-type pathname "so"))
-		  (try-fasl-file (pathname-new-type pathname "bin"))))))
+		  (let ((bin-type (if package/cross-compiling? "nib" "bin")))
+		    (try-fasl-file (pathname-new-type pathname bin-type)))))))
     (if thunk
 	(receive (pathname loader notifier) (thunk)
 	  (values pathname
diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 7a09f410e..88c508c7b 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -331,6 +331,7 @@ USA.
   (export 'package-set-pathname)
   (export 'package/add-child!)
   (export 'package/children)
+  (export 'package/cross-compiling?)
   (export 'package/environment)
   (export 'package/name)
   (export 'package/parent)
diff --git a/src/runtime/option.scm b/src/runtime/option.scm
index a43011bb1..bb364b634 100644
--- a/src/runtime/option.scm
+++ b/src/runtime/option.scm
@@ -40,7 +40,8 @@ USA.
 	    (else #f)))
 
     (define (load-entry entry)
-      (for-each (lambda (thunk) (thunk)) (cdr entry))
+      (fluid-let ((package/cross-compiling? #f))
+	(for-each (lambda (thunk) (thunk)) (cdr entry)))
       (set! loaded-options (cons name loaded-options))
       name)
 
diff --git a/src/runtime/packag.scm b/src/runtime/packag.scm
index 308f688c3..cb69ee20e 100644
--- a/src/runtime/packag.scm
+++ b/src/runtime/packag.scm
@@ -179,6 +179,9 @@ USA.
 ;; Obsolete and ignored:
 (define system-loader/enable-query? #f)
 
+(define package/cross-compiling?
+  #f)
+
 (define (package-set-pathname pathname #!optional os-type)
   (let ((p (->pathname pathname)))
     (pathname-new-type
@@ -195,7 +198,9 @@ USA.
 				   "")))
 			 "-"
 			 (microcode-id/operating-system-suffix os-type)))
-     "pkd")))
+     (if package/cross-compiling?
+	 "dkp"
+	 "pkd"))))
 
 (define-integrable (make-package-file tag version descriptions loads)
   (vector tag version descriptions loads))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index aa93612e3..efd7d106c 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -46,6 +46,7 @@ USA.
 	  package/add-child!
 	  package/create
 	  package/children
+	  package/cross-compiling?
 	  package/environment
 	  package/name
 	  package/parent
diff --git a/src/sf/butils.scm b/src/sf/butils.scm
index 0ce836337..e2e1000bb 100644
--- a/src/sf/butils.scm
+++ b/src/sf/butils.scm
@@ -62,7 +62,7 @@ USA.
 (define sf-directory
   (directory-processor
    "scm"
-   (lambda () "bin")
+   (lambda () (if sf/cross-compiling? "nib" "bin"))
    (lambda (pathname output-directory)
      (sf pathname output-directory))))
 
diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg
index a838fd116..2701cee63 100644
--- a/src/sf/sf.pkg
+++ b/src/sf/sf.pkg
@@ -58,6 +58,7 @@ USA.
   (parent (scode-optimizer))
   (export ()
           sf
+          sf/cross-compiling?
           sf/default-declarations
           sf/default-syntax-table
           sf/pathname-defaulting
diff --git a/src/sf/toplev.scm b/src/sf/toplev.scm
index 85300ea57..d1134f8f4 100644
--- a/src/sf/toplev.scm
+++ b/src/sf/toplev.scm
@@ -31,7 +31,8 @@ USA.
 
 ;;;; User Interface
 
-(define bin-pathname-type "bin")
+(define (bin-pathname-type)
+  (if sf/cross-compiling? "nib" "bin"))
 
 (define (integrate/procedure procedure)
   (procedure-components procedure
@@ -83,6 +84,9 @@ USA.
 
 (define sf/usual-integrations-default-deletions
   '())
+
+(define sf/cross-compiling?
+  #f)
 
 ;;;; File Syntaxer
 
@@ -113,7 +117,7 @@ USA.
 					 (if (> (string-length input-type) 2)
 					     (string-head input-type 2)
 					     input-type))
-			  bin-pathname-type)))))
+			  (bin-pathname-type))))))
 	      (if bin-string
 		  (merge-pathnames bin-string bin-path)
 		  bin-path))
@@ -155,29 +159,30 @@ USA.
 (define (sf/file->scode input-pathname output-pathname
 			environment declarations)
   (fluid-let ((sf/default-externs-pathname
-	       (make-pathname (pathname-host input-pathname)
-			      (pathname-device input-pathname)
-			      (pathname-directory input-pathname)
-			      #f
-			      externs-pathname-type
-			      'newest)))
+	       (lambda ()
+		 (make-pathname (pathname-host input-pathname)
+				(pathname-device input-pathname)
+				(pathname-directory input-pathname)
+				#f
+				(externs-pathname-type)
+				'newest))))
     (receive (expression externs-block externs)
 	(integrate/file input-pathname environment declarations)
       (if output-pathname
 	  (write-externs-file (pathname-new-type output-pathname
-						 externs-pathname-type)
+						 (externs-pathname-type))
 			      externs-block
 			      externs))
       expression)))
 
-(define externs-pathname-type
-  "ext")
+(define (externs-pathname-type)
+  (if sf/cross-compiling? "txe" "ext"))
 
-(define sf/default-externs-pathname
-  (make-pathname #f #f #f #f externs-pathname-type 'newest))
+(define (sf/default-externs-pathname)
+  (make-pathname #f #f #f #f (externs-pathname-type) 'newest))
 
 (define (read-externs-file pathname)
-  (let ((pathname (merge-pathnames pathname sf/default-externs-pathname)))
+  (let ((pathname (merge-pathnames pathname (sf/default-externs-pathname))))
     (let ((namestring (->namestring pathname)))
       (if (file-exists? pathname)
 	  (let ((object (fasload pathname #t))
diff --git a/src/win32/win32.sf b/src/win32/win32.sf
index 46cac8dd4..44fbe0f98 100644
--- a/src/win32/win32.sf
+++ b/src/win32/win32.sf
@@ -34,7 +34,9 @@ USA.
 
 (fluid-let ((sf/default-syntax-table (->environment '(win32))))
   (sf-conditionally "ffimacro")
-  (load "ffimacro.bin" '(win32 ffi-macro))
+  (receive (scm bin spec) (sf/pathname-defaulting "ffimacro" #f #f)
+    scm spec
+    (load bin '(win32 ffi-macro)))
 
   (sf-conditionally "winuser")
   (sf-conditionally "wingdi")