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-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=050570913f337509f63a488a2b859dda8b2774cf;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
(cherry picked from commit dc21a9094a5107ca7e2c8645cb5ebef8da70dd19)
---
diff --git a/src/Makefile.in b/src/Makefile.in
index b45fb9389..be14dc7c7 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -73,10 +73,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)
@@ -227,8 +231,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: syntax-compiler
diff --git a/src/compiler/base/toplev.scm b/src/compiler/base/toplev.scm
index 799f0fef8..ff88f193d 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 cc0cbd7f1..62e0db5d8 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 66710585b..afb822eeb 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 7df1bfc5c..99229edf3 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 9b252c7a6..b1f87e65e 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 8da8a8823..7af3bd172 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 17b8892d4..58aac485a 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 53029a31a..71841fa37 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 8138c1ebf..32d353c69 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 c45d58918..6b8a48635 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 70795a5aa..5fa934ec6 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 a52020432..c5cfb53c9 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 6995779d6..d365fe38d 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 fb1f35237..1cc1103a1 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 6aa467fcc..682306104 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 3472194e0..2781d6862 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 02bfd36e8..311ee5e18 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")