Tmux etc
This commit is contained in:
Ian Keane
parent
276853ba84
commit
1cb167b597
361 changed files with 77302 additions and 4 deletions
|
|
@ -0,0 +1,565 @@
|
|||
;;;; -------------------------------------------------------------------------
|
||||
;;;; ASDF-Bundle
|
||||
|
||||
(uiop/package:define-package :asdf/bundle
|
||||
(:recycle :asdf/bundle :asdf)
|
||||
(:use :uiop/common-lisp :uiop :asdf/upgrade
|
||||
:asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation
|
||||
:asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/defsystem)
|
||||
(:export
|
||||
#:bundle-op #:bundle-type #:program-system
|
||||
#:bundle-system #:bundle-pathname-type #:direct-dependency-files
|
||||
#:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p
|
||||
#:basic-compile-bundle-op #:prepare-bundle-op
|
||||
#:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op
|
||||
#:lib-op #:monolithic-lib-op
|
||||
#:dll-op #:monolithic-dll-op
|
||||
#:deliver-asd-op #:monolithic-deliver-asd-op
|
||||
#:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system
|
||||
#:user-system-p #:user-system #:trivial-system-p
|
||||
#:prologue-code #:epilogue-code #:static-library))
|
||||
(in-package :asdf/bundle)
|
||||
|
||||
(with-upgradability ()
|
||||
(defclass bundle-op (basic-compile-op)
|
||||
;; NB: use of instance-allocated slots for operations is DEPRECATED
|
||||
;; and only supported in a temporary fashion for backward compatibility.
|
||||
;; Supported replacement: Define slots on program-system instead.
|
||||
((bundle-type :initform :no-output-file :reader bundle-type :allocation :class))
|
||||
(:documentation "base class for operations that bundle outputs from multiple components"))
|
||||
|
||||
(defclass monolithic-op (operation) ()
|
||||
(:documentation "A MONOLITHIC operation operates on a system *and all of its
|
||||
dependencies*. So, for example, a monolithic concatenate operation will
|
||||
concatenate together a system's components and all of its dependencies, but a
|
||||
simple concatenate operation will concatenate only the components of the system
|
||||
itself."))
|
||||
|
||||
(defclass monolithic-bundle-op (bundle-op monolithic-op)
|
||||
;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation.
|
||||
;; DEPRECATED. Supported replacement: Define slots on program-system instead.
|
||||
((prologue-code :initform nil :accessor prologue-code)
|
||||
(epilogue-code :initform nil :accessor epilogue-code))
|
||||
(:documentation "operations that are both monolithic-op and bundle-op"))
|
||||
|
||||
(defclass program-system (system)
|
||||
;; New style (ASDF3.1) way of specifying prologue and epilogue on ECL: in the system
|
||||
((prologue-code :initform nil :initarg :prologue-code :reader prologue-code)
|
||||
(epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-code)
|
||||
(no-uiop :initform nil :initarg :no-uiop :reader no-uiop)
|
||||
(prefix-lisp-object-files :initarg :prefix-lisp-object-files
|
||||
:initform nil :accessor prefix-lisp-object-files)
|
||||
(postfix-lisp-object-files :initarg :postfix-lisp-object-files
|
||||
:initform nil :accessor postfix-lisp-object-files)
|
||||
(extra-object-files :initarg :extra-object-files
|
||||
:initform nil :accessor extra-object-files)
|
||||
(extra-build-args :initarg :extra-build-args
|
||||
:initform nil :accessor extra-build-args)))
|
||||
|
||||
(defmethod prologue-code ((x system)) nil)
|
||||
(defmethod epilogue-code ((x system)) nil)
|
||||
(defmethod no-uiop ((x system)) nil)
|
||||
(defmethod prefix-lisp-object-files ((x system)) nil)
|
||||
(defmethod postfix-lisp-object-files ((x system)) nil)
|
||||
(defmethod extra-object-files ((x system)) nil)
|
||||
(defmethod extra-build-args ((x system)) nil)
|
||||
|
||||
(defclass link-op (bundle-op) ()
|
||||
(:documentation "Abstract operation for linking files together"))
|
||||
|
||||
(defclass gather-operation (bundle-op)
|
||||
((gather-operation :initform nil :allocation :class :reader gather-operation)
|
||||
(gather-type :initform :no-output-file :allocation :class :reader gather-type))
|
||||
(:documentation "Abstract operation for gathering many input files from a system"))
|
||||
|
||||
(defun operation-monolithic-p (op)
|
||||
(typep op 'monolithic-op))
|
||||
|
||||
;; Dependencies of a gather-op are the actions of the dependent operation
|
||||
;; for all the (sorted) required components for loading the system.
|
||||
;; Monolithic operations typically use lib-op as the dependent operation,
|
||||
;; and all system-level dependencies as required components.
|
||||
;; Non-monolithic operations typically use compile-op as the dependent operation,
|
||||
;; and all transitive sub-components as required components (excluding other systems).
|
||||
(defmethod component-depends-on ((o gather-operation) (s system))
|
||||
(let* ((mono (operation-monolithic-p o))
|
||||
(go (make-operation (or (gather-operation o) 'compile-op)))
|
||||
(bundle-p (typep go 'bundle-op))
|
||||
;; In a non-mono operation, don't recurse to other systems.
|
||||
;; In a mono operation gathering bundles, don't recurse inside systems.
|
||||
(component-type (if mono (if bundle-p 'system t) '(not system)))
|
||||
;; In the end, only keep system bundles or non-system bundles, depending.
|
||||
(keep-component (if bundle-p 'system '(not system)))
|
||||
(deps
|
||||
;; Required-components only looks at the dependencies of an action, excluding the action
|
||||
;; itself, so it may be safely used by an action recursing on its dependencies (which
|
||||
;; may or may not be an overdesigned API, since in practice we never use it that way).
|
||||
;; Therefore, if we use :goal-operation 'load-op :keep-operation 'load-op, which looks
|
||||
;; cleaner, we will miss the load-op on the requested system itself, which doesn't
|
||||
;; matter for a regular system, but matters, a lot, for a package-inferred-system.
|
||||
;; Using load-op as the goal operation and basic-compile-op as the keep-operation works
|
||||
;; for our needs of gathering all the files we want to include in a bundle.
|
||||
;; Note that we use basic-compile-op rather than compile-op so it will still work on
|
||||
;; systems when *load-system-operation* is load-bundle-op.
|
||||
(required-components
|
||||
s :other-systems mono :component-type component-type :keep-component keep-component
|
||||
:goal-operation 'load-op :keep-operation 'basic-compile-op)))
|
||||
`((,go ,@deps) ,@(call-next-method))))
|
||||
|
||||
;; Create a single fasl for the entire library
|
||||
(defclass basic-compile-bundle-op (bundle-op)
|
||||
((gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :object
|
||||
:allocation :class)
|
||||
(bundle-type :initform :fasl :allocation :class))
|
||||
(:documentation "Base class for compiling into a bundle"))
|
||||
|
||||
;; Analog to prepare-op, for load-bundle-op and compile-bundle-op
|
||||
(defclass prepare-bundle-op (sideway-operation)
|
||||
((sideway-operation
|
||||
:initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op
|
||||
:allocation :class))
|
||||
(:documentation "Operation class for loading the bundles of a system's dependencies"))
|
||||
|
||||
(defclass lib-op (link-op gather-operation non-propagating-operation)
|
||||
((gather-type :initform :object :allocation :class)
|
||||
(bundle-type :initform :lib :allocation :class))
|
||||
(:documentation "Compile the system and produce a linkable static library (.a/.lib)
|
||||
for all the linkable object files associated with the system. Compare with DLL-OP.
|
||||
|
||||
On most implementations, these object files only include extensions to the runtime
|
||||
written in C or another language with a compiler producing linkable object files.
|
||||
On CLASP, ECL, MKCL, these object files _also_ include the contents of Lisp files
|
||||
themselves. In any case, this operation will produce what you need to further build
|
||||
a static runtime for your system, or a dynamic library to load in an existing runtime."))
|
||||
|
||||
;; What works: on ECL, CLASP(?), MKCL, we link the many .o files from the system into the .so;
|
||||
;; on other implementations, we combine (usually concatenate) the .fasl files into one.
|
||||
(defclass compile-bundle-op (basic-compile-bundle-op selfward-operation gather-operation
|
||||
#+(or clasp ecl mkcl) link-op)
|
||||
((selfward-operation :initform '(prepare-bundle-op) :allocation :class))
|
||||
(:documentation "This operator is an alternative to COMPILE-OP. Build a system
|
||||
and all of its dependencies, but build only a single (\"monolithic\") FASL, instead
|
||||
of one per source file, which may be more resource efficient. That monolithic
|
||||
FASL should be loaded with LOAD-BUNDLE-OP, rather than LOAD-OP."))
|
||||
|
||||
(defclass load-bundle-op (basic-load-op selfward-operation)
|
||||
((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class))
|
||||
(:documentation "This operator is an alternative to LOAD-OP. Build a system
|
||||
and all of its dependencies, using COMPILE-BUNDLE-OP. The difference with
|
||||
respect to LOAD-OP is that it builds only a single FASL, which may be
|
||||
faster and more resource efficient."))
|
||||
|
||||
;; NB: since the monolithic-op's can't be sideway-operation's,
|
||||
;; if we wanted lib-op, dll-op, deliver-asd-op to be sideway-operation's,
|
||||
;; we'd have to have the monolithic-op not inherit from the main op,
|
||||
;; but instead inherit from a basic-FOO-op as with basic-compile-bundle-op above.
|
||||
|
||||
(defclass dll-op (link-op gather-operation non-propagating-operation)
|
||||
((gather-type :initform :object :allocation :class)
|
||||
(bundle-type :initform :dll :allocation :class))
|
||||
(:documentation "Compile the system and produce a dynamic loadable library (.so/.dll)
|
||||
for all the linkable object files associated with the system. Compare with LIB-OP."))
|
||||
|
||||
(defclass deliver-asd-op (basic-compile-op selfward-operation)
|
||||
((selfward-operation
|
||||
;; TODO: implement link-op on all implementations, and make that
|
||||
;; '(compile-bundle-op lib-op #-(or clasp ecl mkcl) dll-op)
|
||||
:initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op)
|
||||
:allocation :class))
|
||||
(:documentation "produce an asd file for delivering the system as a single fasl"))
|
||||
|
||||
|
||||
(defclass monolithic-deliver-asd-op (deliver-asd-op monolithic-bundle-op)
|
||||
((selfward-operation
|
||||
;; TODO: implement link-op on all implementations, and make that
|
||||
;; '(monolithic-compile-bundle-op monolithic-lib-op #-(or clasp ecl mkcl) monolithic-dll-op)
|
||||
:initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op)
|
||||
:allocation :class))
|
||||
(:documentation "produce fasl and asd files for combined system and dependencies."))
|
||||
|
||||
(defclass monolithic-compile-bundle-op
|
||||
(basic-compile-bundle-op monolithic-bundle-op
|
||||
#+(or clasp ecl mkcl) link-op gather-operation non-propagating-operation)
|
||||
()
|
||||
(:documentation "Create a single fasl for the system and its dependencies."))
|
||||
|
||||
(defclass monolithic-load-bundle-op (load-bundle-op monolithic-bundle-op)
|
||||
((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class))
|
||||
(:documentation "Load a single fasl for the system and its dependencies."))
|
||||
|
||||
(defclass monolithic-lib-op (lib-op monolithic-bundle-op non-propagating-operation)
|
||||
((gather-type :initform :object :allocation :class))
|
||||
(:documentation "Compile the system and produce a linkable static library (.a/.lib)
|
||||
for all the linkable object files associated with the system or its dependencies. See LIB-OP."))
|
||||
|
||||
(defclass monolithic-dll-op (dll-op monolithic-bundle-op non-propagating-operation)
|
||||
((gather-type :initform :object :allocation :class))
|
||||
(:documentation "Compile the system and produce a dynamic loadable library (.so/.dll)
|
||||
for all the linkable object files associated with the system or its dependencies. See LIB-OP"))
|
||||
|
||||
(defclass image-op (monolithic-bundle-op selfward-operation
|
||||
#+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-operation)
|
||||
((bundle-type :initform :image :allocation :class)
|
||||
(gather-operation :initform 'lib-op :allocation :class)
|
||||
#+(or clasp ecl mkcl) (gather-type :initform :static-library :allocation :class)
|
||||
(selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))
|
||||
(:documentation "create an image file from the system and its dependencies"))
|
||||
|
||||
(defclass program-op (image-op)
|
||||
((bundle-type :initform :program :allocation :class))
|
||||
(:documentation "create an executable file from the system and its dependencies"))
|
||||
|
||||
;; From the ASDF-internal bundle-type identifier, get a filesystem-usable pathname type.
|
||||
(defun bundle-pathname-type (bundle-type)
|
||||
(etypecase bundle-type
|
||||
((or null string) ;; pass through nil or string literal
|
||||
bundle-type)
|
||||
((eql :no-output-file) ;; marker for a bundle-type that has NO output file
|
||||
(error "No output file, therefore no pathname type"))
|
||||
((eql :fasl) ;; the type of a fasl
|
||||
#-(or clasp ecl mkcl) (compile-file-type) ; on image-based platforms, used as input and output
|
||||
#+(or clasp ecl mkcl) "fasb") ; on C-linking platforms, only used as output for system bundles
|
||||
((member :image)
|
||||
#+allegro "dxl"
|
||||
#+(and clisp os-windows) "exe"
|
||||
#-(or allegro (and clisp os-windows)) "image")
|
||||
;; NB: on CLASP and ECL these implementations, we better agree with
|
||||
;; (compile-file-type :type bundle-type))
|
||||
((eql :object) ;; the type of a linkable object file
|
||||
(os-cond ((os-unix-p) "o")
|
||||
((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "o" "obj"))))
|
||||
((member :lib :static-library) ;; the type of a linkable library
|
||||
(os-cond ((os-unix-p) "a")
|
||||
((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib"))))
|
||||
((member :dll :shared-library) ;; the type of a shared library
|
||||
(os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
|
||||
((eql :program) ;; the type of an executable program
|
||||
(os-cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
|
||||
|
||||
;; Compute the output-files for a given bundle action
|
||||
(defun bundle-output-files (o c)
|
||||
(let ((bundle-type (bundle-type o)))
|
||||
(unless (or (eq bundle-type :no-output-file) ;; NIL already means something regarding type.
|
||||
(and (null (input-files o c)) (not (member bundle-type '(:image :program)))))
|
||||
(let ((name (or (component-build-pathname c)
|
||||
(let ((suffix
|
||||
(unless (typep o 'program-op)
|
||||
;; "." is no good separator for Logical Pathnames, so we use "--"
|
||||
(if (operation-monolithic-p o)
|
||||
"--all-systems"
|
||||
;; These use a different type .fasb or .a instead of .fasl
|
||||
#-(or clasp ecl mkcl) "--system"))))
|
||||
(format nil "~A~@[~A~]" (component-name c) suffix))))
|
||||
(type (bundle-pathname-type bundle-type)))
|
||||
(values (list (subpathname (component-pathname c) name :type type))
|
||||
(eq (class-of o) (coerce-class (component-build-operation c)
|
||||
:package :asdf/interface
|
||||
:super 'operation
|
||||
:error nil)))))))
|
||||
|
||||
(defmethod output-files ((o bundle-op) (c system))
|
||||
(bundle-output-files o c))
|
||||
|
||||
#-(or clasp ecl mkcl)
|
||||
(progn
|
||||
(defmethod perform ((o image-op) (c system))
|
||||
(dump-image (output-file o c) :executable (typep o 'program-op)))
|
||||
(defmethod perform :before ((o program-op) (c system))
|
||||
(setf *image-entry-point* (ensure-function (component-entry-point c)))))
|
||||
|
||||
(defclass compiled-file (file-component)
|
||||
((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb"))
|
||||
(:documentation "Class for a file that is already compiled,
|
||||
e.g. as part of the implementation, of an outer build system that calls into ASDF,
|
||||
or of opaque libraries shipped along the source code."))
|
||||
|
||||
(defclass precompiled-system (system)
|
||||
((build-pathname :initarg :fasl))
|
||||
(:documentation "Class For a system that is delivered as a precompiled fasl"))
|
||||
|
||||
(defclass prebuilt-system (system)
|
||||
((build-pathname :initarg :static-library :initarg :lib
|
||||
:accessor prebuilt-system-static-library))
|
||||
(:documentation "Class for a system delivered with a linkable static library (.a/.lib)")))
|
||||
|
||||
|
||||
;;;
|
||||
;;; BUNDLE-OP
|
||||
;;;
|
||||
;;; This operation takes all components from one or more systems and
|
||||
;;; creates a single output file, which may be
|
||||
;;; a FASL, a statically linked library, a shared library, etc.
|
||||
;;; The different targets are defined by specialization.
|
||||
;;;
|
||||
(when-upgrading (:version "3.2.0")
|
||||
;; Cancel any previously defined method
|
||||
(defmethod initialize-instance :after ((instance bundle-op) &rest initargs &key &allow-other-keys)
|
||||
(declare (ignore initargs))))
|
||||
|
||||
(with-upgradability ()
|
||||
(defgeneric trivial-system-p (component))
|
||||
|
||||
(defun user-system-p (s)
|
||||
(and (typep s 'system)
|
||||
(not (builtin-system-p s))
|
||||
(not (trivial-system-p s)))))
|
||||
|
||||
(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
|
||||
(deftype user-system () '(and system (satisfies user-system-p))))
|
||||
|
||||
;;;
|
||||
;;; First we handle monolithic bundles.
|
||||
;;; These are standalone systems which contain everything,
|
||||
;;; including other ASDF systems required by the current one.
|
||||
;;; A PROGRAM is always monolithic.
|
||||
;;;
|
||||
;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
|
||||
;;;
|
||||
(with-upgradability ()
|
||||
(defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
|
||||
;; This function selects output files from direct dependencies;
|
||||
;; your component-depends-on method must gather the correct dependencies in the correct order.
|
||||
(while-collecting (collect)
|
||||
(map-direct-dependencies
|
||||
t o c #'(lambda (sub-o sub-c)
|
||||
(loop :for f :in (funcall key sub-o sub-c)
|
||||
:when (funcall test f) :do (collect f))))))
|
||||
|
||||
(defun pathname-type-equal-function (type)
|
||||
#'(lambda (p) (equalp (pathname-type p) type)))
|
||||
|
||||
(defmethod input-files ((o gather-operation) (c system))
|
||||
(unless (eq (bundle-type o) :no-output-file)
|
||||
(direct-dependency-files
|
||||
o c :key 'output-files
|
||||
:test (pathname-type-equal-function (bundle-pathname-type (gather-type o))))))
|
||||
|
||||
;; Find the operation that produces a given bundle-type
|
||||
(defun select-bundle-operation (type &optional monolithic)
|
||||
(ecase type
|
||||
((:dll :shared-library)
|
||||
(if monolithic 'monolithic-dll-op 'dll-op))
|
||||
((:lib :static-library)
|
||||
(if monolithic 'monolithic-lib-op 'lib-op))
|
||||
((:fasl)
|
||||
(if monolithic 'monolithic-compile-bundle-op 'compile-bundle-op))
|
||||
((:image)
|
||||
'image-op)
|
||||
((:program)
|
||||
'program-op))))
|
||||
|
||||
;;;
|
||||
;;; LOAD-BUNDLE-OP
|
||||
;;;
|
||||
;;; This is like ASDF's LOAD-OP, but using bundle fasl files.
|
||||
;;;
|
||||
(with-upgradability ()
|
||||
(defmethod component-depends-on ((o load-bundle-op) (c system))
|
||||
`((,o ,@(component-sideway-dependencies c))
|
||||
(,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c)
|
||||
,@(call-next-method)))
|
||||
|
||||
(defmethod input-files ((o load-bundle-op) (c system))
|
||||
(when (user-system-p c)
|
||||
(output-files (find-operation o 'compile-bundle-op) c)))
|
||||
|
||||
(defmethod perform ((o load-bundle-op) (c system))
|
||||
(when (input-files o c)
|
||||
(perform-lisp-load-fasl o c)))
|
||||
|
||||
(defmethod mark-operation-done :after ((o load-bundle-op) (c system))
|
||||
(mark-operation-done (find-operation o 'load-op) c)))
|
||||
|
||||
;;;
|
||||
;;; PRECOMPILED FILES
|
||||
;;;
|
||||
;;; This component can be used to distribute ASDF systems in precompiled form.
|
||||
;;; Only useful when the dependencies have also been precompiled.
|
||||
;;;
|
||||
(with-upgradability ()
|
||||
(defmethod trivial-system-p ((s system))
|
||||
(every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))
|
||||
|
||||
(defmethod input-files ((o operation) (c compiled-file))
|
||||
(list (component-pathname c)))
|
||||
(defmethod perform ((o load-op) (c compiled-file))
|
||||
(perform-lisp-load-fasl o c))
|
||||
(defmethod perform ((o load-source-op) (c compiled-file))
|
||||
(perform (find-operation o 'load-op) c))
|
||||
(defmethod perform ((o operation) (c compiled-file))
|
||||
nil))
|
||||
|
||||
;;;
|
||||
;;; Pre-built systems
|
||||
;;;
|
||||
(with-upgradability ()
|
||||
(defmethod trivial-system-p ((s prebuilt-system))
|
||||
t)
|
||||
|
||||
(defmethod perform ((o link-op) (c prebuilt-system))
|
||||
nil)
|
||||
|
||||
(defmethod perform ((o basic-compile-bundle-op) (c prebuilt-system))
|
||||
nil)
|
||||
|
||||
(defmethod perform ((o lib-op) (c prebuilt-system))
|
||||
nil)
|
||||
|
||||
(defmethod perform ((o dll-op) (c prebuilt-system))
|
||||
nil)
|
||||
|
||||
(defmethod component-depends-on ((o gather-operation) (c prebuilt-system))
|
||||
nil)
|
||||
|
||||
(defmethod output-files ((o lib-op) (c prebuilt-system))
|
||||
(values (list (prebuilt-system-static-library c)) t)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; PREBUILT SYSTEM CREATOR
|
||||
;;;
|
||||
(with-upgradability ()
|
||||
(defmethod output-files ((o deliver-asd-op) (s system))
|
||||
(list (make-pathname :name (component-name s) :type "asd"
|
||||
:defaults (component-pathname s))))
|
||||
|
||||
(defmethod perform ((o deliver-asd-op) (s system))
|
||||
(let* ((inputs (input-files o s))
|
||||
(fasl (first inputs))
|
||||
(library (second inputs))
|
||||
(asd (first (output-files o s)))
|
||||
(name (if (and fasl asd) (pathname-name asd) (return-from perform)))
|
||||
(version (component-version s))
|
||||
(dependencies
|
||||
(if (operation-monolithic-p o)
|
||||
;; We want only dependencies, and we use basic-load-op rather than load-op so that
|
||||
;; this will keep working on systems when *load-system-operation* is load-bundle-op
|
||||
(remove-if-not 'builtin-system-p
|
||||
(required-components s :component-type 'system
|
||||
:keep-operation 'basic-load-op))
|
||||
(while-collecting (x) ;; resolve the sideway-dependencies of s
|
||||
(map-direct-dependencies
|
||||
t 'load-op s
|
||||
#'(lambda (o c)
|
||||
(when (and (typep o 'load-op) (typep c 'system))
|
||||
(x c)))))))
|
||||
(depends-on (mapcar 'coerce-name dependencies)))
|
||||
(when (pathname-equal asd (system-source-file s))
|
||||
(cerror "overwrite the asd file"
|
||||
"~/asdf-action:format-action/ is going to overwrite the system definition file ~S ~
|
||||
which is probably not what you want; you probably need to tweak your output translations."
|
||||
(cons o s) asd))
|
||||
(with-open-file (s asd :direction :output :if-exists :supersede
|
||||
:if-does-not-exist :create)
|
||||
(format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%"
|
||||
(operation-monolithic-p o) name)
|
||||
(format s ";;; Built for ~A ~A on a ~A/~A ~A~%"
|
||||
(lisp-implementation-type)
|
||||
(lisp-implementation-version)
|
||||
(software-type)
|
||||
(machine-type)
|
||||
(software-version))
|
||||
(let ((*package* (find-package :asdf-user)))
|
||||
(pprint `(defsystem ,name
|
||||
:class prebuilt-system
|
||||
:version ,version
|
||||
:depends-on ,depends-on
|
||||
:components ((:compiled-file ,(pathname-name fasl)))
|
||||
,@(when library `(:lib ,(file-namestring library))))
|
||||
s)
|
||||
(terpri s)))))
|
||||
|
||||
#-(or clasp ecl mkcl)
|
||||
(defmethod perform ((o basic-compile-bundle-op) (c system))
|
||||
(let* ((input-files (input-files o c))
|
||||
(fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
|
||||
(non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp))
|
||||
(output-files (output-files o c))
|
||||
(output-file (first output-files)))
|
||||
(assert (eq (not input-files) (not output-files)))
|
||||
(when input-files
|
||||
(when non-fasl-files
|
||||
(error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S"
|
||||
(implementation-type) non-fasl-files))
|
||||
(when (or (prologue-code c) (epilogue-code c))
|
||||
(error "prologue-code and epilogue-code are not supported on ~A"
|
||||
(implementation-type)))
|
||||
(with-staging-pathname (output-file)
|
||||
(combine-fasls fasl-files output-file)))))
|
||||
|
||||
(defmethod input-files ((o load-op) (s precompiled-system))
|
||||
(bundle-output-files (find-operation o 'compile-bundle-op) s))
|
||||
|
||||
(defmethod perform ((o load-op) (s precompiled-system))
|
||||
(perform-lisp-load-fasl o s))
|
||||
|
||||
(defmethod component-depends-on ((o load-bundle-op) (s precompiled-system))
|
||||
#+xcl (declare (ignorable o))
|
||||
`((load-op ,s) ,@(call-next-method))))
|
||||
|
||||
#| ;; Example use:
|
||||
(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl")))
|
||||
(asdf:load-system :precompiled-asdf-utils)
|
||||
|#
|
||||
|
||||
#+(or clasp ecl mkcl)
|
||||
(with-upgradability ()
|
||||
|
||||
#+ecl ;; doesn't work on clasp or mkcl (yet?).
|
||||
(unless (use-ecl-byte-compiler-p)
|
||||
(setf *load-system-operation* 'load-bundle-op))
|
||||
|
||||
(defun system-module-pathname (module)
|
||||
(let ((name (coerce-name module)))
|
||||
(some
|
||||
'file-exists-p
|
||||
(list
|
||||
#+clasp (compile-file-pathname (make-pathname :name name :defaults "sys:") :output-type :object)
|
||||
#+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :lib)
|
||||
#+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :object)
|
||||
#+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:")
|
||||
#+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;")))))
|
||||
|
||||
(defun make-prebuilt-system (name &optional (pathname (system-module-pathname name)))
|
||||
"Creates a prebuilt-system if PATHNAME isn't NIL."
|
||||
(when pathname
|
||||
(make-instance 'prebuilt-system
|
||||
:name (coerce-name name)
|
||||
:static-library (resolve-symlinks* pathname))))
|
||||
|
||||
(defmethod component-depends-on :around ((o image-op) (c system))
|
||||
(destructuring-bind ((lib-op . deps)) (call-next-method)
|
||||
(labels ((has-it-p (x) (find x deps :test 'equal :key 'coerce-name))
|
||||
(ensure-linkable-system (x)
|
||||
(unless (has-it-p x)
|
||||
(or (if-let (s (find-system x))
|
||||
(and (system-source-directory x)
|
||||
(list s)))
|
||||
(if-let (p (system-module-pathname x))
|
||||
(list (make-prebuilt-system x p)))))))
|
||||
`((,lib-op
|
||||
,@(unless (no-uiop c)
|
||||
(append (ensure-linkable-system "cmp")
|
||||
(or (ensure-linkable-system "uiop")
|
||||
(ensure-linkable-system "asdf"))))
|
||||
,@deps)))))
|
||||
|
||||
(defmethod perform ((o link-op) (c system))
|
||||
(let* ((object-files (input-files o c))
|
||||
(output (output-files o c))
|
||||
(bundle (first output))
|
||||
(programp (typep o 'program-op))
|
||||
(kind (bundle-type o)))
|
||||
(when output
|
||||
(apply 'create-image
|
||||
bundle (append
|
||||
(when programp (prefix-lisp-object-files c))
|
||||
object-files
|
||||
(when programp (postfix-lisp-object-files c)))
|
||||
:kind kind
|
||||
:prologue-code (when programp (prologue-code c))
|
||||
:epilogue-code (when programp (epilogue-code c))
|
||||
:build-args (when programp (extra-build-args c))
|
||||
:extra-object-files (when programp (extra-object-files c))
|
||||
:no-uiop (no-uiop c)
|
||||
(when programp `(:entry-point ,(component-entry-point c))))))))
|
||||
|
|
@ -0,0 +1,392 @@
|
|||
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
|
||||
;;;
|
||||
;;; c-toolchain.lisp --- Generic support compiling and linking C code.
|
||||
;;;
|
||||
;;; Copyright (C) 2005-2006, Dan Knap <dankna@accela.net>
|
||||
;;; Copyright (C) 2005-2006, Emily Backes <lucca@accela.net>
|
||||
;;; Copyright (C) 2007, Stelian Ionescu <sionescu@cddr.org>
|
||||
;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
|
||||
;;;
|
||||
;;; Permission is hereby granted, free of charge, to any person
|
||||
;;; obtaining a copy of this software and associated documentation
|
||||
;;; files (the "Software"), to deal in the Software without
|
||||
;;; restriction, including without limitation the rights to use, copy,
|
||||
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
|
||||
;;; of the Software, and to permit persons to whom the Software is
|
||||
;;; furnished to do so, subject to the following conditions:
|
||||
;;;
|
||||
;;; The above copyright notice and this permission notice shall be
|
||||
;;; included in all copies or substantial portions of the Software.
|
||||
;;;
|
||||
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
||||
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
||||
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
|
||||
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
|
||||
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
|
||||
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
|
||||
;;; DEALINGS IN THE SOFTWARE.
|
||||
;;;
|
||||
|
||||
(in-package #:cffi-toolchain)
|
||||
|
||||
;;; Utils
|
||||
|
||||
(defun parse-command-flags (flags)
|
||||
(let ((separators '(#\Space #\Tab #\Newline #\Return)))
|
||||
(remove-if 'emptyp (split-string flags :separator separators))))
|
||||
|
||||
(defun parse-command-flags-list (strings)
|
||||
(loop for flags in strings append (parse-command-flags flags)))
|
||||
|
||||
(defun program-argument (x)
|
||||
(etypecase x
|
||||
(string x)
|
||||
(pathname (native-namestring x))))
|
||||
|
||||
(defun invoke (command &rest args)
|
||||
(when (pathnamep command)
|
||||
(setf command (native-namestring command))
|
||||
#+os-unix
|
||||
(unless (absolute-pathname-p command)
|
||||
(setf command (strcat "./" command))))
|
||||
(let ((cmd (cons command (mapcar 'program-argument args))))
|
||||
(safe-format! *debug-io* "; ~A~%" (escape-command cmd))
|
||||
(run-program cmd :output :interactive :error-output :interactive)))
|
||||
|
||||
|
||||
;;; C support
|
||||
|
||||
(defparameter *cc* nil "C compiler")
|
||||
(defparameter *cc-flags* nil "flags for the C compiler")
|
||||
(defparameter *ld* nil "object linker") ;; NB: can actually be the same as *cc*
|
||||
(defparameter *ld-exe-flags* nil "flags for linking executables via *ld*")
|
||||
(defparameter *ld-dll-flags* nil "flags for linking shared library via *ld*")
|
||||
(defparameter *linkkit-start* nil "flags for the implementation linkkit, start")
|
||||
(defparameter *linkkit-end* nil "flags for the implementation linkkit, end")
|
||||
|
||||
(defun link-all-library (lib)
|
||||
;; Flags to provide to cc to link a whole library into an executable
|
||||
(when lib
|
||||
(if (featurep :darwin) ;; actually, LLVM ld vs GNU ld
|
||||
`("-Wl,-force_load" ,lib)
|
||||
`("-Wl,--whole-archive" ,lib "-Wl,--no-whole-archive"))))
|
||||
|
||||
(defun normalize-flags (directory flags)
|
||||
(loop for val in (parse-command-flags flags) collect
|
||||
(cond
|
||||
((find (first-char val) "-+/") val)
|
||||
((probe-file* (subpathname directory val)))
|
||||
(t val))))
|
||||
|
||||
(defun implementation-file (file &optional type)
|
||||
(subpathname (lisp-implementation-directory) file
|
||||
:type (bundle-pathname-type type)))
|
||||
|
||||
;; TODO: on CCL, extract data from
|
||||
;; (pathname (strcat "ccl:lisp-kernel/" (ccl::kernel-build-directory) "/Makefile")) ?
|
||||
|
||||
#+clisp
|
||||
(progn
|
||||
(defparameter *clisp-toolchain-parameters*
|
||||
'(("CC" *cc*)
|
||||
("CFLAGS" *cc-flags* t)
|
||||
("CLFLAGS" *cc-exe-flags* t)
|
||||
("LIBS" *linkkit-start* t)
|
||||
("X_LIBS" *linkkit-end* t)))
|
||||
(defun clisp-toolchain-parameters (&optional linkset)
|
||||
(nest
|
||||
(let* ((linkset (ensure-pathname
|
||||
(or linkset "base")
|
||||
:defaults (lisp-implementation-directory)
|
||||
:ensure-absolute t
|
||||
:ensure-directory t
|
||||
:want-existing t))
|
||||
(makevars (subpathname linkset "makevars"))))
|
||||
(with-input-file (params makevars :if-does-not-exist nil))
|
||||
(when params)
|
||||
(loop for l = (read-line params nil nil) while l
|
||||
finally (appendf *linkkit-start* (normalize-flags linkset "modules.o")) do)
|
||||
(if-let (p (position #\= l)))
|
||||
(let ((var (subseq l 0 p))
|
||||
;; strip the start and end quote characters
|
||||
(val (subseq l (+ p 2) (- (length l) 1)))))
|
||||
(if-let (param (cdr (assoc var *clisp-toolchain-parameters* :test 'equal))))
|
||||
(destructuring-bind (sym &optional normalizep) param
|
||||
(setf (symbol-value sym)
|
||||
(if normalizep (normalize-flags linkset val) val))))
|
||||
(setf *ld* *cc*
|
||||
*ld-exe-flags* `(,@*cc-flags* #-darwin "-Wl,--export-dynamic")
|
||||
*ld-dll-flags* (list* #+darwin "-dynamiclib" ;; -bundle ?
|
||||
#-darwin "-shared"
|
||||
*cc-flags*))))
|
||||
|
||||
;; TODO: for CMUCL, see whatever uses its linker.sh,
|
||||
;; and teach it to accept additional objects / libraries
|
||||
;; as it links a runtime plus a core into an executable
|
||||
|
||||
#+ecl
|
||||
(defun ecl-toolchain-parameters ()
|
||||
(setf *cc* c:*cc*
|
||||
*cc-flags* `(,@(parse-command-flags c::*cc-flags*)
|
||||
,@(parse-command-flags c:*user-cc-flags*))
|
||||
;; For the below, we just use c::build-FOO
|
||||
*ld* *cc*
|
||||
*ld-exe-flags* *cc-flags*
|
||||
*ld-dll-flags* *cc-flags*
|
||||
*linkkit-start* nil
|
||||
*linkkit-end* nil))
|
||||
|
||||
#+mkcl
|
||||
(defun mkcl-toolchain-parameters ()
|
||||
(setf *cc* compiler::*cc*
|
||||
*cc-flags* (parse-command-flags compiler::*cc-flags*)
|
||||
;; For the below, we just use compiler::build-FOO
|
||||
*ld* *cc*
|
||||
*ld-exe-flags* *cc-flags*
|
||||
*ld-dll-flags* *cc-flags*
|
||||
*linkkit-start* nil
|
||||
*linkkit-end* nil))
|
||||
|
||||
#+sbcl
|
||||
(progn
|
||||
(defparameter *sbcl-toolchain-parameters*
|
||||
'(("CC" *cc*)
|
||||
("CFLAGS" *cc-flags* t)
|
||||
("LINKFLAGS" *ld-exe-flags* t)
|
||||
("USE_LIBSBCL" *linkkit-start* t)
|
||||
("LIBS" *linkkit-end* t)))
|
||||
(defun sbcl-toolchain-parameters ()
|
||||
(nest
|
||||
(let* ((sbcl-home (lisp-implementation-directory))
|
||||
(sbcl.mk (subpathname sbcl-home "sbcl.mk"))))
|
||||
(with-input-file (params sbcl.mk :if-does-not-exist nil))
|
||||
(when params)
|
||||
(loop for l = (read-line params nil nil) while l
|
||||
finally (appendf *linkkit-end* '("-lm")) do)
|
||||
(if-let (p (position #\= l)))
|
||||
(let ((var (subseq l 0 p))
|
||||
(val (subseq l (1+ p)))))
|
||||
(if-let (param (cdr (assoc var *sbcl-toolchain-parameters* :test 'equal))))
|
||||
(destructuring-bind (sym &optional normalizep) param
|
||||
(setf (symbol-value sym)
|
||||
(if normalizep (normalize-flags sbcl-home val) val))))
|
||||
(unless (featurep :sb-linkable-runtime)
|
||||
(setf *linkkit-start* nil *linkkit-end* nil))
|
||||
(setf *ld* *cc* ;; !
|
||||
*ld-dll-flags* (list* #+darwin "-dynamiclib" #-darwin "-shared"
|
||||
*cc-flags*))))
|
||||
|
||||
;;; Taken from sb-grovel
|
||||
(defun split-cflags (string)
|
||||
(remove-if (lambda (flag)
|
||||
(zerop (length flag)))
|
||||
(loop
|
||||
for start = 0 then (if end (1+ end) nil)
|
||||
for end = (and start (position #\Space string :start start))
|
||||
while start
|
||||
collect (subseq string start end))))
|
||||
|
||||
(defun default-toolchain-parameters ()
|
||||
;; The values below are legacy guesses from previous versions of CFFI.
|
||||
;; It would be nice to clean them up, remove unneeded guesses,
|
||||
;; annotate every guess with some comment explaining the context.
|
||||
;; TODO: have proper implementation-provided linkkit parameters
|
||||
;; for all implementations as above, and delete the below altogether.
|
||||
(let ((arch-flags
|
||||
;; Former *cpu-word-size-flags*
|
||||
#+arm '("-marm")
|
||||
#+arm64 '()
|
||||
#-(or arm arm64)
|
||||
(ecase (cffi:foreign-type-size :pointer)
|
||||
(4 '("-m32"))
|
||||
(8 '("-m64")))))
|
||||
(setf *cc*
|
||||
(or (getenvp "CC")
|
||||
#+(or cygwin (not windows)) "cc"
|
||||
"gcc")
|
||||
*cc-flags*
|
||||
(append
|
||||
arch-flags
|
||||
;; For MacPorts
|
||||
#+darwin (list "-I" "/opt/local/include/")
|
||||
;; ECL internal flags
|
||||
#+ecl (parse-command-flags c::*cc-flags*)
|
||||
;; FreeBSD non-base header files
|
||||
#+freebsd (list "-I" "/usr/local/include/")
|
||||
(split-cflags (getenv "CFLAGS")))
|
||||
*ld* *cc*
|
||||
*ld-exe-flags* `(,@arch-flags #-darwin "-Wl,--export-dynamic")
|
||||
*ld-dll-flags* (list* #+darwin "-dynamiclib" ;; -bundle ?
|
||||
#-darwin "-shared"
|
||||
*cc-flags*)
|
||||
*linkkit-start* nil
|
||||
*linkkit-end* nil)))
|
||||
|
||||
(defun ensure-toolchain-parameters ()
|
||||
#+clisp (unless *cc* (clisp-toolchain-parameters))
|
||||
#+ecl (unless *cc* (ecl-toolchain-parameters))
|
||||
#+mkcl (unless *cc* (mkcl-toolchain-parameters))
|
||||
#+sbcl (unless *cc* (sbcl-toolchain-parameters))
|
||||
(unless *cc* (default-toolchain-parameters)))
|
||||
|
||||
;; Actually initialize toolchain parameters
|
||||
(ignore-errors (ensure-toolchain-parameters))
|
||||
|
||||
|
||||
(defun call-with-temporary-output (output-file fun)
|
||||
(let ((output-file (ensure-pathname output-file :want-file t :ensure-absolute t :truenamize t)))
|
||||
(with-temporary-file
|
||||
(:pathname tmp :direction :output
|
||||
:prefix (strcat (native-namestring (pathname-directory-pathname output-file))
|
||||
(pathname-name output-file) "-tmp")
|
||||
:suffix ""
|
||||
:type (pathname-type output-file))
|
||||
(funcall fun tmp)
|
||||
(rename-file-overwriting-target tmp output-file))))
|
||||
|
||||
(defmacro with-temporary-output ((output-file-var &optional (output-file-val output-file-var))
|
||||
&body body)
|
||||
"Create an output file atomically, by executing the BODY while OUTPUT-FILE-VAR
|
||||
is bound to a temporary file name, then atomically renaming that temporary file to OUTPUT-FILE-VAL."
|
||||
`(call-with-temporary-output ,output-file-val (lambda (,output-file-var) ,@body)))
|
||||
|
||||
(defun invoke-builder (builder output-file &rest args)
|
||||
"Invoke the C Compiler with given OUTPUT-FILE and arguments ARGS"
|
||||
(with-temporary-output (output-file)
|
||||
(apply 'invoke `(,@builder ,output-file ,@args))))
|
||||
|
||||
(defun cc-compile (output-file inputs)
|
||||
(apply 'invoke-builder (list *cc* "-o") output-file
|
||||
"-c" (append *cc-flags* #-windows '("-fPIC") inputs)))
|
||||
|
||||
(defun link-executable (output-file inputs)
|
||||
(apply 'invoke-builder (list *ld* "-o") output-file
|
||||
(append *ld-exe-flags* inputs)))
|
||||
|
||||
(defun link-lisp-executable (output-file inputs)
|
||||
#+ecl
|
||||
(let ((c::*ld-flags*
|
||||
(format nil "-Wl,--export-dynamic ~@[ ~A~]"
|
||||
c::*ld-flags*)))
|
||||
(c::build-program output-file :lisp-files inputs))
|
||||
#+mkcl (compiler::build-program
|
||||
output-file :lisp-object-files (mapcar 'program-argument inputs)
|
||||
:on-missing-lisp-object-initializer nil)
|
||||
#+(and sbcl (not sb-linkable-runtime)) (error "Your SBCL doesn't support :SB-LINKABLE-RUNTIME")
|
||||
#-(or ecl mkcl)
|
||||
(link-executable output-file `(,@*linkkit-start* ,@inputs ,@*linkkit-end*)))
|
||||
|
||||
(defun link-static-library (output-file inputs)
|
||||
#+ecl (c::build-static-library output-file :lisp-files inputs)
|
||||
#+mkcl (compiler::build-static-library
|
||||
output-file :lisp-object-files (mapcar 'program-argument inputs)
|
||||
:on-missing-lisp-object-initializer nil)
|
||||
#-(or ecl mkcl)
|
||||
(with-temporary-output (output-file)
|
||||
(delete-file-if-exists output-file)
|
||||
#+(or bsd linux windows)
|
||||
(apply 'invoke
|
||||
`(;; TODO: make it portable to BSD.
|
||||
;; ar D is also on FreeBSD, but not on OpenBSD or Darwin, dunno about NetBSD;
|
||||
;; ar T seems to only be on Linux (means something different on Darwin). Sigh.
|
||||
;; A MRI script might be more portable... not, only supported by GNU binutils.
|
||||
;; I couldn't get libtool to work, and it's not ubiquitous anyway.
|
||||
;; ,@`("libtool" "--mode=link" ,*cc* ,@*cc-flags* "-static" "-o" ,output-file)
|
||||
;; "Solution": never link .a's into further .a's, only link .o's into .a's,
|
||||
;; which implied changes that are now the case in ASDF 3.2.0.
|
||||
#+bsd ,@`("ar" "rcs" ,output-file) ;; NB: includes darwin
|
||||
#+linux ,@`("ar" "rcsDT" ,output-file)
|
||||
#+windows ,@`("lib" "-nologo" ,(strcat "-out:" (native-namestring output-file)))
|
||||
,@inputs))
|
||||
#-(or bsd linux windows)
|
||||
(error "Not implemented on your system")))
|
||||
|
||||
(defun link-shared-library (output-file inputs)
|
||||
;; remove the library so we won't possibly be overwriting
|
||||
;; the code of any existing process
|
||||
(delete-file-if-exists output-file)
|
||||
#+ecl (c::build-shared-library output-file :lisp-files inputs)
|
||||
#+mkcl (compiler::build-shared-library
|
||||
output-file :lisp-object-files (mapcar 'program-argument inputs)
|
||||
:on-missing-lisp-object-initializer nil)
|
||||
#-(or ecl mkcl)
|
||||
;; Don't use a temporary file, because linking is sensitive to the output file name :-/ (or put it in a temporary directory?)
|
||||
(apply 'invoke *ld* "-o" output-file
|
||||
(append *ld-dll-flags* inputs)))
|
||||
|
||||
|
||||
;;; Computing file names
|
||||
|
||||
(defun make-c-file-name (output-defaults &optional suffix)
|
||||
(make-pathname :type "c"
|
||||
:name (strcat (pathname-name output-defaults) suffix)
|
||||
:defaults output-defaults))
|
||||
|
||||
(defun make-o-file-name (output-defaults &optional suffix)
|
||||
(make-pathname :type (bundle-pathname-type :object)
|
||||
:name (format nil "~A~@[~A~]" (pathname-name output-defaults) suffix)
|
||||
:defaults output-defaults))
|
||||
|
||||
(defun make-so-file-name (defaults)
|
||||
(make-pathname :type (bundle-pathname-type :shared-library)
|
||||
:defaults defaults))
|
||||
|
||||
(defun make-exe-file-name (defaults)
|
||||
(make-pathname :type (bundle-pathname-type :program)
|
||||
:defaults defaults))
|
||||
|
||||
|
||||
;;; Implement link-op on image-based platforms.
|
||||
#-(or clasp ecl mkcl)
|
||||
(defmethod perform ((o link-op) (c system))
|
||||
(let* ((inputs (input-files o c))
|
||||
(output (first (output-files o c)))
|
||||
(kind (bundle-type o)))
|
||||
(when output ;; some operations skip any output when there is no input
|
||||
(ecase kind
|
||||
(:program (link-executable output inputs))
|
||||
((:lib :static-library) (link-static-library output inputs))
|
||||
((:dll :shared-library) (link-shared-library output inputs))))))
|
||||
|
||||
(defclass c-file (source-file)
|
||||
((cflags :initarg :cflags :initform :default)
|
||||
(type :initform "c")))
|
||||
|
||||
(defmethod output-files ((o compile-op) (c c-file))
|
||||
(let* ((i (first (input-files o c)))
|
||||
(base (format nil "~(~{~a~^__~}~)"
|
||||
(mapcar (lambda (x) (substitute-if #\_ (complement #'alphanumericp) x))
|
||||
(component-find-path c))))
|
||||
(path (make-pathname :defaults i :name base)))
|
||||
(list (make-o-file-name path)
|
||||
(make-so-file-name path))))
|
||||
|
||||
(defmethod perform ((o compile-op) (c c-file))
|
||||
(let ((i (first (input-files o c))))
|
||||
(destructuring-bind (.o .so) (output-files o c)
|
||||
(cc-compile .o (list i))
|
||||
(link-shared-library .so (list .o)))))
|
||||
|
||||
(defmethod perform ((o load-op) (c c-file))
|
||||
(let ((o (second (input-files o c))))
|
||||
(cffi:load-foreign-library (file-namestring o) :search-path (list (pathname-directory-pathname o)))))
|
||||
|
||||
(setf (find-class 'asdf::c-file) (find-class 'c-file))
|
||||
|
||||
(defclass o-file (source-file)
|
||||
((cflags :initarg :cflags :initform :default)
|
||||
(type :initform (bundle-pathname-type :object)))
|
||||
(:documentation "class for pre-compile object components"))
|
||||
|
||||
(defmethod output-files ((op compile-op) (c o-file))
|
||||
(let* ((o (first (input-files op c)))
|
||||
(so (apply-output-translations (make-so-file-name o))))
|
||||
(values (list o so) t)))
|
||||
|
||||
(defmethod perform ((o load-op) (c o-file))
|
||||
(let ((so (second (input-files o c))))
|
||||
(cffi:load-foreign-library (file-namestring so) :search-path (list (pathname-directory-pathname so)))))
|
||||
|
||||
(setf (find-class 'asdf::o-file) (find-class 'o-file))
|
||||
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
|
||||
;;;
|
||||
;;; package.lisp --- Toolchain DEFPACKAGE.
|
||||
;;;
|
||||
;;; Permission is hereby granted, free of charge, to any person
|
||||
;;; obtaining a copy of this software and associated documentation
|
||||
;;; files (the "Software"), to deal in the Software without
|
||||
;;; restriction, including without limitation the rights to use, copy,
|
||||
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
|
||||
;;; of the Software, and to permit persons to whom the Software is
|
||||
;;; furnished to do so, subject to the following conditions:
|
||||
;;;
|
||||
;;; The above copyright notice and this permission notice shall be
|
||||
;;; included in all copies or substantial portions of the Software.
|
||||
;;;
|
||||
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
||||
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
||||
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
|
||||
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
|
||||
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
|
||||
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
|
||||
;;; DEALINGS IN THE SOFTWARE.
|
||||
;;;
|
||||
|
||||
(uiop:define-package #:cffi-toolchain
|
||||
(:mix #:asdf #:uiop #:common-lisp)
|
||||
(:import-from #:asdf/bundle
|
||||
#:link-op #:bundle-pathname-type #:bundle-type
|
||||
#:gather-operation #:gather-type)
|
||||
(:export
|
||||
;; Variables
|
||||
#:*cc* #:*cc-flags*
|
||||
#:*ld* #:*ld-exe-flags* #:*ld-dll-flags*
|
||||
#:*linkkit-start* #:*linkkit-end*
|
||||
;; Functions from c-toolchain
|
||||
#:make-c-file-name #:make-o-file-name
|
||||
#:make-so-file-name #:make-exe-file-name
|
||||
#:parse-command-flags #:parse-command-flags-list
|
||||
#:invoke #:invoke-build #:cc-compile
|
||||
#:link-static-library #:link-shared-library
|
||||
#:link-executable #:link-lisp-executable
|
||||
;; ASDF classes
|
||||
#:c-file #:o-file
|
||||
#:static-runtime-op #:static-image-op #:static-program-op
|
||||
))
|
||||
|
|
@ -0,0 +1,95 @@
|
|||
;; FIXME: arrange packages so that this can be moved in ASDF some time later?
|
||||
|
||||
(in-package #:cffi-toolchain)
|
||||
|
||||
(defun static-ops-enabled-p ()
|
||||
(ensure-toolchain-parameters)
|
||||
(and (or *linkkit-start* *linkkit-end*) t))
|
||||
|
||||
(defclass static-runtime-op (monolithic-bundle-op link-op selfward-operation) ()
|
||||
(:documentation "Create a Lisp runtime linkable library for the system and its dependencies."))
|
||||
(defmethod bundle-type ((o static-runtime-op)) :program)
|
||||
(defmethod selfward-operation ((o static-runtime-op)) 'monolithic-lib-op)
|
||||
|
||||
(defmethod output-files ((o static-runtime-op) (s system))
|
||||
#-(or ecl mkcl)
|
||||
(list (subpathname (component-pathname s)
|
||||
(strcat (coerce-name s) "-runtime")
|
||||
:type (bundle-pathname-type :program))))
|
||||
|
||||
(defmethod perform ((o static-runtime-op) (s system))
|
||||
(link-lisp-executable
|
||||
(output-file o s)
|
||||
(link-all-library (first (input-files o s)))))
|
||||
|
||||
(defclass static-image-op (image-op) ()
|
||||
(:documentation "Create a statically linked standalone image for the system."))
|
||||
#-(or ecl mkcl) (defmethod selfward-operation ((o static-image-op)) '(load-op static-runtime-op))
|
||||
#+(or ecl mkcl) (defmethod gather-operation ((o static-image-op)) 'compile-op)
|
||||
#+(or ecl mkcl) (defmethod gather-operation ((o static-image-op)) :object)
|
||||
|
||||
(defclass static-program-op (program-op static-image-op) ()
|
||||
(:documentation "Create a statically linked standalone executable for the system."))
|
||||
|
||||
;; Problem? Its output may conflict with the program-op output :-/
|
||||
|
||||
#-(or ecl mkcl)
|
||||
(defmethod perform ((o static-image-op) (s system))
|
||||
#-(or clisp sbcl) (error "Not implemented yet")
|
||||
#+(or clisp sbcl)
|
||||
(let* ((name (coerce-name s))
|
||||
(runtime (output-file 'static-runtime-op s))
|
||||
(image
|
||||
#+clisp (implementation-file "base/lispinit.mem")
|
||||
#+sbcl (subpathname (lisp-implementation-directory) "sbcl.core"))
|
||||
(output (output-file o s))
|
||||
(child-op (if (typep o 'program-op) 'program-op 'image-op)))
|
||||
(with-temporary-output (tmp output)
|
||||
(apply 'invoke runtime
|
||||
#+clisp "-M" #+sbcl "--core" image
|
||||
`(#+clisp ,@'("--silent" "-ansi" "-norc" "-x")
|
||||
#+sbcl ,@'("--noinform" "--non-interactive" "--no-sysinit" "--no-userinit" "--eval")
|
||||
,(with-safe-io-syntax (:package :asdf)
|
||||
(let ((*print-pretty* nil)
|
||||
(*print-case* :downcase))
|
||||
(format
|
||||
;; This clever staging allows to put things in a single form,
|
||||
;; as required for CLISP not to print output for the first form,
|
||||
;; yet allow subsequent forms to rely on packages defined by former forms.
|
||||
nil "'(~@{#.~S~^ ~})"
|
||||
'(require "asdf")
|
||||
'(in-package :asdf)
|
||||
`(progn
|
||||
(setf asdf:*central-registry* ',asdf:*central-registry*)
|
||||
(initialize-source-registry ',asdf::*source-registry-parameter*)
|
||||
(initialize-output-translations ',asdf::*output-translations-parameter*)
|
||||
(upgrade-asdf)
|
||||
,@(if-let (ql-home
|
||||
(symbol-value (find-symbol* '*quicklisp-home* 'ql-setup nil)))
|
||||
`((load ,(subpathname ql-home "setup.lisp"))))
|
||||
(load-system "cffi-grovel")
|
||||
;; We force the (final step of the) operation to take place
|
||||
(defmethod operation-done-p
|
||||
((operation ,child-op) (system (eql (find-system ,name))))
|
||||
nil)
|
||||
;; Some implementations (notably SBCL) die as part of dumping an image,
|
||||
;; so redirect output-files to desired destination, for this processs might
|
||||
;; never otherwise get a chance to move the file to destination.
|
||||
(defmethod output-files
|
||||
((operation ,child-op) (system (eql (find-system ,name))))
|
||||
(values (list ,tmp) t))
|
||||
(operate ',child-op ,name)
|
||||
(quit))))))))))
|
||||
|
||||
#+(or ecl mkcl)
|
||||
(defmethod perform ((o static-image-op) (s system))
|
||||
(let (#+ecl
|
||||
(c::*ld-flags*
|
||||
(format nil "-Wl,--export-dynamic ~@[ ~A~]"
|
||||
c::*ld-flags*)))
|
||||
(call-next-method)))
|
||||
|
||||
;; Allow for :static-FOO-op in ASDF definitions.
|
||||
(setf (find-class 'asdf::static-runtime-op) (find-class 'static-runtime-op)
|
||||
(find-class 'asdf::static-image-op) (find-class 'static-image-op)
|
||||
(find-class 'asdf::static-program-op) (find-class 'static-program-op))
|
||||
Loading…
Add table
Add a link
Reference in a new issue