From 7d958b9d2b1466ed379ea5a72b98ed56024ade02 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Sat, 31 Aug 2013 18:10:40 -0700 Subject: [PATCH] ffi/build.scm.in: Support building shims separately. A handful of new top-level bindings make a portickle Makefile. gdbm-shim.so: gdbm-shim.o gdbm-adapter.o echo "(link-shim)" | mit-scheme --batch-mode -- -o $@ $^ -lgdbm The new procedures (generate-shim, compile-shim, link-shim and install-shim) autoload ffi/build.scm, which captured the build configuration of the machine. Compile-bundle and install-bundle are also provided. --- src/ffi/build.scm.in | 124 +++++++++++++++++++++++++++ src/ffi/ffi.pkg | 14 ++- src/microcode/configure.ac | 1 + src/microcode/makegen/Makefile.in.in | 2 +- src/microcode/pruxffi.h | 1 + src/runtime/ffi.scm | 35 ++++++++ src/runtime/pathnm.scm | 14 +++ src/runtime/runtime.pkg | 9 +- 8 files changed, 197 insertions(+), 3 deletions(-) create mode 100644 src/ffi/build.scm.in diff --git a/src/ffi/build.scm.in b/src/ffi/build.scm.in new file mode 100644 index 000000000..847c1995d --- /dev/null +++ b/src/ffi/build.scm.in @@ -0,0 +1,124 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts + Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Build Utilities +;;; package: (ffi build) + +(define (compile-bundle) + (with-system-library-directories + '("./") + (lambda () + (if (eq? microcode-id/compiled-code-type 'C) + (fluid-let ((compiler:invoke-c-compiler? #f)) + (compile-dir) + (c-compile-pkgs)) + (compile-dir))))) + +(define (compile-shim) + (run-command (append cc-cmdline-prefix (command-line)))) + +(define (link-shim) + (run-command (append CCLD LDFLAGS (command-line) MODULE_LDFLAGS))) + +(define (install-bundle) + (let* ((name (working-directory-name)) + (target-dir (->namestring (system-library-pathname name #f)))) + (run-command (list "rm" "-rf" target-dir)) + (run-command (list "mkdir" target-dir)) + (run-command (append (list "install" "-m" "644") + (command-line) + (list target-dir))))) + +(define (install-shim libname) + (run-command (list "install" "-m" "644" + (string-append libname "-shim.so") + (string-append libname "-types.bin") + (string-append libname "-const.bin") + (->namestring (system-library-directory-pathname))))) + +(define (parse-words string) + (burst-string string char-set:whitespace #t)) + +(define CCLD (parse-words "@CCLD@")) +(define LDFLAGS (parse-words "@LDFLAGS@")) +(define MODULE_LDFLAGS (parse-words "@MODULE_LDFLAGS@")) +(define AUXDIR/ "@libdir@/@AUXDIR_NAME@/") +(define INSTALL_DATA (parse-words "@INSTALL_DATA@")) +(define cc-cmdline-prefix + (append + (filter + (lambda (i) (not (string=? "-DMIT_SCHEME" i))) + (parse-words "@CC@ @DEFS@ @SCHEME_DEFS@ @CPPFLAGS@")) + (list (string-append "-I" (->namestring (system-library-pathname "")))) + (parse-words "@CFLAGS@ @MODULE_CFLAGS@"))) + +(define (working-directory-name) + (let ((name (pathname-name (directory-pathname-as-file + (working-directory-pathname))))) + (if (and (string? name) (not (string-null? name))) + name + (error "Could not find the current working directory name.")))) + +(define (run-command command) + (with-notification + (lambda (port) + (write-string (decorated-string-append "" " " "" command) port) + (newline port)) + (lambda () + (let ((code (run-synchronous-subprocess + (car command) (cdr command) + 'working-directory (working-directory-pathname)))) + (if (not (zero? code)) + (error "Process exited with error code:" code command)))))) + +(define (compile-dir) + (let ((name (working-directory-name))) + (if (file-exists? (pathname-new-type name "sf")) + (begin + (load (pathname-new-type name "sf")) + (load (pathname-new-type name "cbf"))) + (load "compile")))) + +(define (c-compile-pkgs) + (let* ((name (working-directory-name)) + (root + (if (string=? name "star-parser") + "parser" + name)) + (compile-pkg + (lambda (os) + (cbf-conditionally (string-append root "-" os ".pkd"))))) + (compile-pkg "unx") + (compile-pkg "w32") + (compile-pkg "os2"))) + +(define (cbf-conditionally pathname) + (let ((input (pathname-default-type pathname "bin")) + (file-type (if (eq? microcode-id/compiled-code-type 'C) + "c" "com"))) + (if (file-modification-timeenvironment '(ffi)) 'c-generate) library prefix)) + +(define (compile-shim) + (load-ffi-quietly) + ((environment-lookup (->environment '(ffi)) 'compile-shim))) + +(define (link-shim) + (load-ffi-quietly) + ((environment-lookup (->environment '(ffi)) 'link-shim))) + +(define (install-shim library) + (load-ffi-quietly) + ((environment-lookup (->environment '(ffi)) 'install-shim) library)) + +(define (compile-bundle) + (load-ffi-quietly) + ((environment-lookup (->environment '(ffi)) 'compile-bundle))) + +(define (install-bundle) + (load-ffi-quietly) + ((environment-lookup (->environment '(ffi)) 'install-bundle))) + +(define (load-ffi-quietly) + (if (not (name->package '(FFI))) + (with-notification + (lambda (port) (write-string "Loading FFI option" port)) + (lambda () + (fluid-let ((load/suppress-loading-message? #t)) + (load-option 'ffi)))))) + + (define calloutback-stack '()) (define %trace? #f) diff --git a/src/runtime/pathnm.scm b/src/runtime/pathnm.scm index d75ebdd29..f6d845ed6 100644 --- a/src/runtime/pathnm.scm +++ b/src/runtime/pathnm.scm @@ -621,6 +621,20 @@ these rules: (else #f))) (%find-library-directory))) +(define (with-system-library-directories directories thunk) + (define (existing-directory directory) + (let ((dirpath (pathname-as-directory (merge-pathnames directory)))) + (if (file-directory? dirpath) + dirpath + (error:file-operation dirpath + "find" "directory" "no such directory" + 'with-system-library-directories + directories)))) + (fluid-let ((library-directory-path + (append library-directory-path + (map existing-directory directories)))) + (thunk))) + (define (%find-library-directory) (pathname-simplify (or (find-matching-item library-directory-path file-directory?) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 6feca330f..b2052c63b 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3124,6 +3124,7 @@ USA. pathname? system-library-directory-pathname system-library-pathname + with-system-library-directories uri->pathname user-homedir-pathname) (initialization (initialize-package!))) @@ -3331,7 +3332,13 @@ USA. free register-c-callback de-register-c-callback - outf-error) + outf-error + generate-shim + compile-shim + link-shim + install-shim + compile-bundle + install-bundle) (initialization (initialize-package!))) (define-package (runtime program-copier) -- 2.25.1