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   ((selfward-operation :initform 'monolithic-lib-op :allocation :class))
  11   (:documentation "Create a Lisp runtime linkable library for the system and its dependencies."))
  12
  13 (defmethod output-files ((o static-runtime-op) (s system))
  14   #-(or ecl mkcl)
  15   (list (subpathname (component-pathname s)
  16                      (strcat (coerce-name s) "-runtime")
  17                      :type (bundle-pathname-type :program))))
  18
  19 (defmethod perform ((o static-runtime-op) (s system))
  20   (link-lisp-executable
  21    (output-file o s)
  22    (link-all-library (first (input-files o s)))))
  23
  24 (defclass static-image-op (image-op)
  25   (#-(or ecl mkcl) (selfward-operation :initform '(load-op static-runtime-op) :allocation :class)
  26    #+(or ecl mkcl)
  27    (gather-operation :initform 'compile-op :allocation :class)
  28    #+(or ecl mkcl)
  29    (gather-type :initform :object :allocation :class))
  30   (:documentation "Create a statically linked standalone image for the system."))
  31
  32 (defclass static-program-op (program-op static-image-op)
  33   (#-(or ecl mkcl) (selfward-operation :initform '(load-op static-runtime-op) :allocation :class)
  34    #+(or ecl mkcl)
  35    (gather-operation :initform 'compile-op :allocation :class)
  36    #+(or ecl mkcl)
  37    (gather-type :initform :object :allocation :class))
  38   (:documentation "Create a statically linked standalone executable for the system."))
  39
  40 ;; Problem? Its output may conflict with the program-op output :-/
  41
  42 #-(or ecl mkcl)
  43 (defmethod perform ((o static-image-op) (s system))
  44   #-(or clisp sbcl) (error "Not implemented yet")
  45   #+(or clisp sbcl)
  46   (let* ((name (coerce-name s))
  47          (runtime (output-file 'static-runtime-op s))
  48          (image
  49            #+clisp (implementation-file "base/lispinit.mem")
  50            #+sbcl (subpathname (lisp-implementation-directory) "sbcl.core"))
  51          (output (output-file o s))
  52          (child-op (if (typep o 'program-op) 'program-op 'image-op)))
  53     (with-temporary-output (tmp output)
  54       (apply 'invoke runtime
  55              #+clisp "-M" #+sbcl "--core" image
  56              `(#+clisp ,@'("--silent" "-ansi" "-norc" "-x")
  57                #+sbcl ,@'("--noinform" "--non-interactive" "--no-sysinit" "--no-userinit" "--eval")
  58                ,(with-safe-io-syntax ()
  59                   (let ((*print-pretty* nil)
  60                         (*print-case* :downcase))
  61                     (format
  62                      ;; This clever staging allows to put things in a single form,
  63                      ;; as required for CLISP not to print output for the first form,
  64                      ;; yet allow subsequent forms to rely on packages defined by former forms.
  65                      nil "'(#.~S #.~S)"
  66                      '(require "asdf")
  67                      `(progn
  68                         ,@(if-let (ql-home (symbol-value
  69                                             (find-symbol* '*quicklisp-home* 'ql-setup nil)))
  70                             `((load ,(subpathname ql-home "setup.lisp"))))
  71                         (setf *central-registry* ',*central-registry*)
  72                         (initialize-source-registry
  73                          ',asdf/source-registry:*source-registry-parameter*)
  74                         (initialize-output-translations
  75                          ',asdf/output-translations:*output-translations-parameter*)
  76                         (load-system "cffi-grovel")
  77                         (defmethod operation-done-p ((operation ,child-op)
  78                                                      (system (eql (find-system ,name))))
  79                           nil)
  80                         (defmethod output-files ((operation ,child-op)
  81                                                  (system (eql (find-system ,name))))
  82                           (values (list ,tmp) t))
  83                         (operate ',child-op ,name)
  84                         (quit))))))))))
  85
  86 #+(or ecl mkcl)
  87 (defmethod perform ((o static-image-op) (s system))
  88   (let (#+ecl
  89         (c::*ld-flags*
  90          (format nil "-Wl,--export-dynamic ~@[ ~A~]"
  91                  c::*ld-flags*)))
  92     (call-next-method)))
  93
  94 ;; Allow for :static-FOO-op in ASDF definitions.
  95 (setf (find-class 'asdf::static-runtime-op) (find-class 'static-runtime-op)
  96       (find-class 'asdf::static-image-op) (find-class 'static-image-op)
  97       (find-class 'asdf::static-program-op) (find-class 'static-program-op))