3rdparties/software/cffi_0.21.0/toolchain/static-link.lisp (4750 bytes)
1 ;; FIXME: arrange packages so that this can be moved in ASDF some time later? 2 3 (in-package #:cffi-toolchain) 4 5 (defun static-ops-enabled-p () 6 (ensure-toolchain-parameters) 7 (and (or *linkkit-start* *linkkit-end*) t)) 8 9 (defclass static-runtime-op (monolithic-bundle-op link-op selfward-operation) () 10 (:documentation "Create a Lisp runtime linkable library for the system and its dependencies.")) 11 (defmethod bundle-type ((o static-runtime-op)) :program) 12 (defmethod selfward-operation ((o static-runtime-op)) 'monolithic-lib-op) 13 14 (defmethod output-files ((o static-runtime-op) (s system)) 15 #-(or ecl mkcl) 16 (list (subpathname (component-pathname s) 17 (strcat (coerce-name s) "-runtime") 18 :type (bundle-pathname-type :program)))) 19 20 (defmethod perform ((o static-runtime-op) (s system)) 21 (link-lisp-executable 22 (output-file o s) 23 (link-all-library (first (input-files o s))))) 24 25 (defclass static-image-op (image-op) () 26 (:documentation "Create a statically linked standalone image for the system.")) 27 #-(or ecl mkcl) (defmethod selfward-operation ((o static-image-op)) '(load-op static-runtime-op)) 28 #+(or ecl mkcl) (defmethod gather-operation ((o static-image-op)) 'compile-op) 29 #+(or ecl mkcl) (defmethod gather-operation ((o static-image-op)) :object) 30 31 (defclass static-program-op (program-op static-image-op) () 32 (:documentation "Create a statically linked standalone executable for the system.")) 33 34 ;; Problem? Its output may conflict with the program-op output :-/ 35 36 #-(or ecl mkcl) 37 (defmethod perform ((o static-image-op) (s system)) 38 #-(or clisp sbcl) (error "Not implemented yet") 39 #+(or clisp sbcl) 40 (let* ((name (coerce-name s)) 41 (runtime (output-file 'static-runtime-op s)) 42 (image 43 #+clisp (implementation-file "base/lispinit.mem") 44 #+sbcl (subpathname (lisp-implementation-directory) "sbcl.core")) 45 (output (output-file o s)) 46 (child-op (if (typep o 'program-op) 'program-op 'image-op))) 47 (with-temporary-output (tmp output) 48 (apply 'invoke runtime 49 #+clisp "-M" #+sbcl "--core" image 50 `(#+clisp ,@'("--silent" "-ansi" "-norc" "-x") 51 #+sbcl ,@'("--noinform" "--non-interactive" "--no-sysinit" "--no-userinit" "--eval") 52 ,(with-safe-io-syntax (:package :asdf) 53 (let ((*print-pretty* nil) 54 (*print-case* :downcase)) 55 (format 56 ;; This clever staging allows to put things in a single form, 57 ;; as required for CLISP not to print output for the first form, 58 ;; yet allow subsequent forms to rely on packages defined by former forms. 59 nil "'(~@{#.~S~^ ~})" 60 '(require "asdf") 61 '(in-package :asdf) 62 `(progn 63 (setf asdf:*central-registry* ',asdf:*central-registry*) 64 (initialize-source-registry ',asdf::*source-registry-parameter*) 65 (initialize-output-translations ',asdf::*output-translations-parameter*) 66 (upgrade-asdf) 67 ,@(if-let (ql-home 68 (symbol-value (find-symbol* '*quicklisp-home* 'ql-setup nil))) 69 `((load ,(subpathname ql-home "setup.lisp")))) 70 (load-system "cffi-grovel") 71 ;; We force the (final step of the) operation to take place 72 (defmethod operation-done-p 73 ((operation ,child-op) (system (eql (find-system ,name)))) 74 nil) 75 ;; Some implementations (notably SBCL) die as part of dumping an image, 76 ;; so redirect output-files to desired destination, for this processs might 77 ;; never otherwise get a chance to move the file to destination. 78 (defmethod output-files 79 ((operation ,child-op) (system (eql (find-system ,name)))) 80 (values (list ,tmp) t)) 81 (operate ',child-op ,name) 82 (quit)))))))))) 83 84 #+(or ecl mkcl) 85 (defmethod perform ((o static-image-op) (s system)) 86 (let (#+ecl 87 (c::*ld-flags* 88 (format nil "-Wl,--export-dynamic ~@[ ~A~]" 89 c::*ld-flags*))) 90 (call-next-method))) 91 92 ;; Allow for :static-FOO-op in ASDF definitions. 93 (setf (find-class 'asdf::static-runtime-op) (find-class 'static-runtime-op) 94 (find-class 'asdf::static-image-op) (find-class 'static-image-op) 95 (find-class 'asdf::static-program-op) (find-class 'static-program-op))