From dc21a9094a5107ca7e2c8645cb5ebef8da70dd19 Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Tue, 11 Dec 2018 15:52:07 +0000 Subject: [PATCH] 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 --- src/Makefile.in | 10 ++++++-- src/compiler/base/toplev.scm | 21 +++++++++------- src/compiler/machines/C/compiler.sf | 5 +++- src/compiler/machines/C/decls.scm | 17 +++++++------ src/compiler/machines/i386/decls.scm | 17 +++++++------ src/compiler/machines/svm/compiler.sf | 5 +++- src/compiler/machines/svm/decls.scm | 17 +++++++------ src/compiler/machines/x86-64/decls.scm | 17 +++++++------ src/cref/redpkg.scm | 5 ++-- src/runtime/load.scm | 3 ++- src/runtime/make.scm | 1 + src/runtime/option.scm | 3 ++- src/runtime/packag.scm | 7 +++++- src/runtime/runtime.pkg | 1 + src/sf/butils.scm | 2 +- src/sf/sf.pkg | 1 + src/sf/toplev.scm | 33 +++++++++++++++----------- src/win32/win32.sf | 4 +++- 18 files changed, 99 insertions(+), 70 deletions(-) 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") -- 2.25.1