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   #+(or clisp cmucl sbcl)
   7   (and (version<= "3.1.6" (asdf-version))
   8        #+sbcl (probe-file* (subpathname (lisp-implementation-directory) "sbcl.o")) ;; sbcl 1.2.17
   9        t))
  10
  11 (defclass static-runtime-op (monolithic-bundle-op asdf/bundle::link-op selfward-operation)
  12   ((selfward-operation :initform 'monolithic-lib-op :allocation :class))
  13   (:documentation "Create a Lisp runtime linkable library for the system and its dependencies."))
  14
  15 (defmethod output-files ((o static-runtime-op) (s system))
  16   (list (subpathname (component-pathname s)
  17                      (format nil "~A-runtime" (coerce-name s))
  18                      :type (asdf/bundle::bundle-pathname-type :program))))
  19
  20 (defun get-shared-objects (executable)
  21   (loop for line in (run-program
  22                      `("ldd" ,(native-namestring executable))
  23                      :output :lines)
  24         ;; Let's avoid using cl-ppcre just for this... If your filename has a #\>, you lose.
  25         for end = (position #\( line :from-end t)
  26         for start = (when end (position #\> line :from-end t :end end))
  27         for object = (when start (string-trim " " (subseq line (1+ start) end)))
  28         unless (emptyp object)
  29         collect object))
  30
  31 #+clisp
  32 (defun clisp-file (x &optional type)
  33   (subpathname custom:*lib-directory* x
  34                :type (asdf/bundle:bundle-pathname-type type)))
  35
  36 (defun implementation-link-flags ()
  37   #-(or clisp cmucl sbcl) (error "Not implemented yet")
  38   #+clisp ;; TODO: cleanup clisp support.
  39   `("-Wl,--export-dynamic" "-Wl,--whole-archive"
  40     ,(clisp-file "base/lisp" :static-library)
  41     "-Wl,--no-whole-archive"
  42     ;; It's not clear which exactly of the below objects are or aren't needed.
  43     ,(clisp-file "base/libgnu" :static-library)
  44     ,(clisp-file "base/bogomips" :object)
  45     ;; This is ugly, but I don't know how to make it work otherwise.
  46     ,(clisp-file "base/calls" :object) "/usr/lib/libavcall.so.0.0.0" "/usr/lib/libcallback.so.0.0.0"
  47     ,(clisp-file "base/gettext" :object)
  48     ,(clisp-file "base/modules" :object)
  49     ,(clisp-file "base/regexi" :object)
  50     ;; Or should we be using no-readline.a instead? How to tell?
  51     ;; By searching for libreadline in the get-shared-objects results?
  52     ,(clisp-file "base/readline" :object)
  53     ;; #+linux ,(clisp-file "bindings/glibc/linux.o")
  54     ,@(get-shared-objects (clisp-file "base/lisp.run")))
  55   #+cmucl
  56   (let ((init (subpathname lisp::*cmucl-core-path* "exec-init.o"))
  57         (lisp-lib (subpathname lisp::*cmucl-core-path* "lisp.a")))
  58     ;; for backward compatibility, with the 10.5 SDK installed, add "-mmacosx-version-min=10.5"
  59     #+darwin `(,init "-all_load" ,lisp-lib "-rdynamic")
  60     #+linux `("-Wl,--whole-archive" ,lisp-lib
  61               "-Wl,--no-whole-archive" ,init "-rdynamic" "-ldl" "-lm"))
  62   #+sbcl
  63   `(,(subpathname (lisp-implementation-directory) "sbcl.o")
  64     "-Wl,--export-dynamic,--no-whole-archive"
  65     ;;"-Wl,--dynamic-list" ,exported-symbols-file
  66     ;; TODO: need to get the exact list to work on *all* platforms,
  67     ;; by looking at all the Config files in sbcl/src/runtime/ -- Ouch!
  68     ,@(when (featurep :linux) '("-ldl"))
  69     ,@(when (featurep :sb-thread) '("-lpthread"))
  70     ,@(when (featurep :sb-core-compression) '("-lz"))
  71     "-lm"))
  72
  73 (defmethod perform ((o static-runtime-op) (s system))
  74   (link-executable
  75    (output-file o s)
  76    `(#+linux "-Wl,--whole-archive" #+darwin "-all_load"
  77      ,@(input-files o s) ,@(implementation-link-flags))))
  78
  79 (defclass static-image-op (image-op)
  80   ((selfward-operation :initform '(load-op static-runtime-op) :allocation :class))
  81   (:documentation "Create a statically linked standalone image for the system."))
  82
  83 (defclass static-program-op (static-image-op program-op) ()
  84   (:documentation "Create a statically linked standalone executable for the system."))
  85
  86 ;; Problem? Its output may conflict with the program-op output :-/
  87
  88 (defmethod perform ((o static-image-op) (s system))
  89   #-(or clisp cmucl sbcl) (error "Not implemented yet")
  90   #+(or clisp cmucl sbcl)
  91   (let* ((name (coerce-name s))
  92          (runtime (output-file 'static-runtime-op s))
  93          (image
  94            #+clisp (clisp-file "base/lispinit.mem")
  95            #+cmucl lisp::*cmucl-core-path*
  96            #+sbcl (subpathname (lisp-implementation-directory) "sbcl.core"))
  97          (output (output-file o s))
  98          (child-op (if (typep o 'program-op) 'program-op 'image-op)))
  99     (with-temporary-output (tmp output)
 100       (apply 'invoke runtime
 101              #+clisp "-M" #+cmucl "-core" #+sbcl "--core" image
 102              `(#+clisp ,@'("--silent" "-ansi" "-norc" "-x")
 103                #+cmucl ,@'("-quiet" "-noinit" "-nositeinit" "-batch" "-eval")
 104                #+sbcl ,@'("--noinform" "--non-interactive" "--no-sysinit" "--no-userinit" "--eval")
 105                ,(with-safe-io-syntax ()
 106                   (let ((*print-pretty* nil)
 107                         (*print-case* :downcase))
 108                     (format
 109                      ;; This clever staging allows to put things in a single form,
 110                      ;; as required for CLISP not to print output for the first form,
 111                      ;; yet allow subsequent forms to rely on packages defined by former forms.
 112                      nil "'(#.~S #.~S)"
 113                      '(require "asdf")
 114                      `(progn
 115                         ,@(if-let (ql-home (symbol-value
 116                                             (find-symbol* '*quicklisp-home* 'ql-setup nil)))
 117                             `((load ,(subpathname ql-home "setup.lisp"))))
 118                         (initialize-source-registry
 119                          ,asdf/source-registry:*source-registry-parameter*)
 120                         (initialize-output-translations
 121                          ,asdf/output-translations:*output-translations-parameter*)
 122                         (load-system "cffi-grovel")
 123                         (defmethod operation-done-p ((operation ,child-op)
 124                                                      (system (eql (find-system ,name))))
 125                           nil)
 126                         (defmethod output-files ((operation ,child-op)
 127                                                  (system (eql (find-system ,name))))
 128                           (values (list ,tmp) t))
 129                         (operate ',child-op ,name)
 130                         (quit))))))))))
 131
 132 ;; Allow for :static-FOO-op in ASDF definitions.
 133 (setf (find-class 'asdf::static-runtime-op) (find-class 'static-runtime-op)
 134       (find-class 'asdf::static-image-op) (find-class 'static-image-op)
 135       (find-class 'asdf::static-program-op) (find-class 'static-program-op))