toolchain/static-link.lisp

   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))