toolchain/c-toolchain.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; c-toolchain.lisp --- Generic support compiling and linking C code.
   4 ;;;
   5 ;;; Copyright (C) 2005-2006, Dan Knap <dankna@accela.net>
   6 ;;; Copyright (C) 2005-2006, Emily Backes <lucca@accela.net>
   7 ;;; Copyright (C) 2007, Stelian Ionescu <sionescu@cddr.org>
   8 ;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
   9 ;;;
  10 ;;; Permission is hereby granted, free of charge, to any person
  11 ;;; obtaining a copy of this software and associated documentation
  12 ;;; files (the "Software"), to deal in the Software without
  13 ;;; restriction, including without limitation the rights to use, copy,
  14 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  15 ;;; of the Software, and to permit persons to whom the Software is
  16 ;;; furnished to do so, subject to the following conditions:
  17 ;;;
  18 ;;; The above copyright notice and this permission notice shall be
  19 ;;; included in all copies or substantial portions of the Software.
  20 ;;;
  21 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  22 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  23 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  24 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  25 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  26 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  27 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  28 ;;; DEALINGS IN THE SOFTWARE.
  29 ;;;
  30
  31 (in-package #:cffi-toolchain)
  32
  33 ;;; Utils
  34
  35 (defun parse-command-flags (flags)
  36   (let ((separators '(#\Space #\Tab #\Newline #\Return)))
  37     (remove-if 'emptyp (split-string flags :separator separators))))
  38
  39 (defun parse-command-flags-list (strings)
  40   (loop for flags in strings append (parse-command-flags flags)))
  41
  42 (defun program-argument (x)
  43   (etypecase x
  44     (string x)
  45     (pathname (native-namestring x))))
  46
  47 (defun invoke (command &rest args)
  48   (when (pathnamep command)
  49     (setf command (native-namestring command))
  50     #+os-unix
  51     (unless (absolute-pathname-p command)
  52       (setf command (strcat "./" command))))
  53   (let ((cmd (cons command (mapcar 'program-argument args))))
  54     (safe-format! *debug-io* "; ~A~%" (escape-command cmd))
  55     (run-program cmd :output :interactive :error-output :interactive)))
  56
  57
  58 ;;; C support
  59
  60 (defparameter *cc* nil "C compiler")
  61 (defparameter *cc-flags* nil "flags for the C compiler")
  62 (defparameter *ld* nil "object linker") ;; NB: can actually be the same as *cc*
  63 (defparameter *ld-exe-flags* nil "flags for linking executables via *ld*")
  64 (defparameter *ld-dll-flags* nil "flags for linking shared library via *ld*")
  65 (defparameter *linkkit-start* nil "flags for the implementation linkkit, start")
  66 (defparameter *linkkit-end* nil "flags for the implementation linkkit, end")
  67
  68 (defun link-all-library (lib)
  69   ;; Flags to provide to cc to link a whole library into an executable
  70   (when lib
  71     (if (featurep :darwin) ;; actually, LLVM ld vs GNU ld
  72         `("-Wl,-force_load" ,lib)
  73         `("-Wl,--whole-archive" ,lib "-Wl,--no-whole-archive"))))
  74
  75 (defun normalize-flags (directory flags)
  76   (loop for val in (parse-command-flags flags) collect
  77         (cond
  78           ((find (first-char val) "-+/") val)
  79           ((probe-file* (subpathname directory val)))
  80           (t val))))
  81
  82 (defun implementation-file (file &optional type)
  83   (subpathname (lisp-implementation-directory) file
  84                :type (bundle-pathname-type type)))
  85
  86 ;; TODO: on CCL, extract data from
  87 ;; (pathname (strcat "ccl:lisp-kernel/" (ccl::kernel-build-directory) "/Makefile")) ?
  88
  89 #+clisp
  90 (progn
  91   (defparameter *clisp-toolchain-parameters*
  92     '(("CC" *cc*)
  93       ("CFLAGS" *cc-flags* t)
  94       ("CLFLAGS" *cc-exe-flags* t)
  95       ("LIBS" *linkkit-start* t)
  96       ("X_LIBS" *linkkit-end* t)))
  97   (defun clisp-toolchain-parameters (&optional linkset)
  98     (nest
  99      (let* ((linkset (ensure-pathname
 100                       (or linkset "base")
 101                       :defaults (lisp-implementation-directory)
 102                       :ensure-absolute t
 103                       :ensure-directory t
 104                       :want-existing t))
 105             (makevars (subpathname linkset "makevars"))))
 106      (with-input-file (params makevars :if-does-not-exist nil))
 107      (when params)
 108      (loop for l = (read-line params nil nil) while l
 109            finally (appendf *linkkit-start* (normalize-flags linkset "modules.o")) do)
 110      (if-let (p (position #\= l)))
 111      (let ((var (subseq l 0 p))
 112            ;; strip the start and end quote characters
 113            (val (subseq l (+ p 2) (- (length l) 1)))))
 114      (if-let (param (cdr (assoc var *clisp-toolchain-parameters* :test 'equal))))
 115      (destructuring-bind (sym &optional normalizep) param
 116        (setf (symbol-value sym)
 117              (if normalizep (normalize-flags linkset val) val))))
 118     (setf *ld* *cc*
 119           *ld-exe-flags* `(,@*cc-flags* #-darwin "-Wl,--export-dynamic")
 120           *ld-dll-flags* (list* #+darwin "-dynamiclib" ;; -bundle ?
 121                                 #-darwin "-shared"
 122                                 *cc-flags*))))
 123
 124 ;; TODO: for CMUCL, see whatever uses its linker.sh,
 125 ;; and teach it to accept additional objects / libraries
 126 ;; as it links a runtime plus a core into an executable
 127
 128 #+ecl
 129 (defun ecl-toolchain-parameters ()
 130   (setf *cc* c:*cc*
 131         *cc-flags* `(,@(parse-command-flags c::*cc-flags*)
 132                      ,@(parse-command-flags c:*user-cc-flags*))
 133         ;; For the below, we just use c::build-FOO
 134         *ld* *cc*
 135         *ld-exe-flags* *cc-flags*
 136         *ld-dll-flags* *cc-flags*
 137         *linkkit-start* nil
 138         *linkkit-end* nil))
 139
 140 #+mkcl
 141 (defun mkcl-toolchain-parameters ()
 142   (setf *cc* compiler::*cc*
 143         *cc-flags* (parse-command-flags compiler::*cc-flags*)
 144         ;; For the below, we just use compiler::build-FOO
 145         *ld* *cc*
 146         *ld-exe-flags* *cc-flags*
 147         *ld-dll-flags* *cc-flags*
 148         *linkkit-start* nil
 149         *linkkit-end* nil))
 150
 151 #+sbcl
 152 (progn
 153   (defparameter *sbcl-toolchain-parameters*
 154     '(("CC" *cc*)
 155       ("CFLAGS" *cc-flags* t)
 156       ("LINKFLAGS" *ld-exe-flags* t)
 157       ("USE_LIBSBCL" *linkkit-start* t)
 158       ("LIBS" *linkkit-end* t)))
 159   (defun sbcl-toolchain-parameters ()
 160     (nest
 161      (let* ((sbcl-home (lisp-implementation-directory))
 162             (sbcl.mk (subpathname sbcl-home "sbcl.mk"))))
 163      (with-input-file (params sbcl.mk :if-does-not-exist nil))
 164      (when params)
 165      (loop for l = (read-line params nil nil) while l
 166            finally (appendf *linkkit-end* '("-lm")) do)
 167      (if-let (p (position #\= l)))
 168      (let ((var (subseq l 0 p))
 169            (val (subseq l (1+ p)))))
 170      (if-let (param (cdr (assoc var *sbcl-toolchain-parameters* :test 'equal))))
 171      (destructuring-bind (sym &optional normalizep) param
 172        (setf (symbol-value sym)
 173              (if normalizep (normalize-flags sbcl-home val) val))))
 174     (unless (featurep :sb-linkable-runtime)
 175       (setf *linkkit-start* nil *linkkit-end* nil))
 176     (setf *ld* *cc* ;; !
 177           *ld-dll-flags* (list* #+darwin "-dynamiclib" #-darwin "-shared"
 178                                 *cc-flags*))))
 179
 180 ;;; Taken from sb-grovel
 181 (defun split-cflags (string)
 182   (remove-if (lambda (flag)
 183                (zerop (length flag)))
 184              (loop
 185                for start = 0 then (if end (1+ end) nil)
 186                for end = (and start (position #\Space string :start start))
 187                while start
 188                collect (subseq string start end))))
 189
 190 (defun default-toolchain-parameters ()
 191   ;; The values below are legacy guesses from previous versions of CFFI.
 192   ;; It would be nice to clean them up, remove unneeded guesses,
 193   ;; annotate every guess with some comment explaining the context.
 194   ;; TODO: have proper implementation-provided linkkit parameters
 195   ;; for all implementations as above, and delete the below altogether.
 196   (let ((arch-flags
 197          ;; Former *cpu-word-size-flags*
 198          #+arm '("-marm")
 199          #+arm64 '()
 200          #-(or arm arm64)
 201          (ecase (cffi:foreign-type-size :pointer)
 202                 (4 '("-m32"))
 203                 (8 '("-m64")))))
 204     (setf *cc*
 205           (or (getenvp "CC")
 206               #+(or cygwin (not windows)) "cc"
 207               "gcc")
 208           *cc-flags*
 209           (append
 210            arch-flags
 211            ;; For MacPorts
 212            #+darwin (list "-I" "/opt/local/include/")
 213            ;; ECL internal flags
 214            #+ecl (parse-command-flags c::*cc-flags*)
 215            ;; FreeBSD non-base header files
 216            #+freebsd (list "-I" "/usr/local/include/")
 217            (split-cflags (getenv "CFLAGS")))
 218           *ld* *cc*
 219           *ld-exe-flags* `(,@arch-flags #-darwin "-Wl,--export-dynamic")
 220           *ld-dll-flags* (list* #+darwin "-dynamiclib" ;; -bundle ?
 221                                 #-darwin "-shared"
 222                                 *cc-flags*)
 223           *linkkit-start* nil
 224           *linkkit-end* nil)))
 225
 226 (defun ensure-toolchain-parameters ()
 227   #+clisp (unless *cc* (clisp-toolchain-parameters))
 228   #+ecl (unless *cc* (ecl-toolchain-parameters))
 229   #+mkcl (unless *cc* (mkcl-toolchain-parameters))
 230   #+sbcl (unless *cc* (sbcl-toolchain-parameters))
 231   (unless *cc* (default-toolchain-parameters)))
 232
 233 ;; Actually initialize toolchain parameters
 234 (ignore-errors (ensure-toolchain-parameters))
 235
 236
 237 (defun call-with-temporary-output (output-file fun)
 238   (let ((output-file (ensure-pathname output-file :want-file t :ensure-absolute t :truenamize t)))
 239     (with-temporary-file
 240         (:pathname tmp :direction :output
 241          :prefix (strcat (native-namestring (pathname-directory-pathname output-file))
 242                          (pathname-name output-file) "-tmp")
 243          :suffix ""
 244          :type (pathname-type output-file))
 245       (funcall fun tmp)
 246       (rename-file-overwriting-target tmp output-file))))
 247
 248 (defmacro with-temporary-output ((output-file-var &optional (output-file-val output-file-var))
 249                                  &body body)
 250   "Create an output file atomically, by executing the BODY while OUTPUT-FILE-VAR
 251 is bound to a temporary file name, then atomically renaming that temporary file to OUTPUT-FILE-VAL."
 252   `(call-with-temporary-output ,output-file-val (lambda (,output-file-var) ,@body)))
 253
 254 (defun invoke-builder (builder output-file &rest args)
 255   "Invoke the C Compiler with given OUTPUT-FILE and arguments ARGS"
 256   (with-temporary-output (output-file)
 257     (apply 'invoke `(,@builder ,output-file ,@args))))
 258
 259 (defun cc-compile (output-file inputs)
 260   (apply 'invoke-builder (list *cc* "-o") output-file
 261          "-c" (append *cc-flags* #-windows '("-fPIC") inputs)))
 262
 263 (defun link-executable (output-file inputs)
 264   (apply 'invoke-builder (list *ld* "-o") output-file
 265          (append *ld-exe-flags* inputs)))
 266
 267 (defun link-lisp-executable (output-file inputs)
 268   #+ecl
 269   (let ((c::*ld-flags*
 270          (format nil "-Wl,--export-dynamic ~@[ ~A~]"
 271                  c::*ld-flags*)))
 272     (c::build-program output-file :lisp-files inputs))
 273   #+mkcl (compiler::build-program
 274           output-file :lisp-object-files (mapcar 'program-argument inputs)
 275           :on-missing-lisp-object-initializer nil)
 276   #+(and sbcl (not sb-linkable-runtime)) (error "Your SBCL doesn't support :SB-LINKABLE-RUNTIME")
 277   #-(or ecl mkcl)
 278   (link-executable output-file `(,@*linkkit-start* ,@inputs ,@*linkkit-end*)))
 279
 280 (defun link-static-library (output-file inputs)
 281   #+ecl (c::build-static-library output-file :lisp-files inputs)
 282   #+mkcl (compiler::build-static-library
 283           output-file :lisp-object-files (mapcar 'program-argument inputs)
 284           :on-missing-lisp-object-initializer nil)
 285   #-(or ecl mkcl)
 286   (with-temporary-output (output-file)
 287     (delete-file-if-exists output-file)
 288     #+(or bsd linux windows)
 289     (apply 'invoke
 290            `(;; TODO: make it portable to BSD.
 291              ;; ar D is also on FreeBSD, but not on OpenBSD or Darwin, dunno about NetBSD;
 292              ;; ar T seems to only be on Linux (means something different on Darwin). Sigh.
 293              ;; A MRI script might be more portable... not, only supported by GNU binutils.
 294              ;; I couldn't get libtool to work, and it's not ubiquitous anyway.
 295              ;; ,@`("libtool" "--mode=link" ,*cc* ,@*cc-flags* "-static" "-o" ,output-file)
 296              ;; "Solution": never link .a's into further .a's, only link .o's into .a's,
 297              ;; which implied changes that are now the case in ASDF 3.2.0.
 298              #+bsd ,@`("ar" "rcs" ,output-file) ;; NB: includes darwin
 299              #+linux ,@`("ar" "rcsDT" ,output-file)
 300              #+windows ,@`("lib" "-nologo" ,(strcat "-out:" (native-namestring output-file)))
 301              ,@inputs))
 302     #-(or bsd linux windows)
 303     (error "Not implemented on your system")))
 304
 305 (defun link-shared-library (output-file inputs)
 306   ;; remove the library so we won't possibly be overwriting
 307   ;; the code of any existing process
 308   (delete-file-if-exists output-file)
 309   #+ecl (c::build-shared-library output-file :lisp-files inputs)
 310   #+mkcl (compiler::build-shared-library
 311           output-file :lisp-object-files (mapcar 'program-argument inputs)
 312           :on-missing-lisp-object-initializer nil)
 313   #-(or ecl mkcl)
 314   ;; Don't use a temporary file, because linking is sensitive to the output file name :-/ (or put it in a temporary directory?)
 315   (apply 'invoke *ld* "-o" output-file
 316          (append *ld-dll-flags* inputs)))
 317
 318
 319 ;;; Computing file names
 320
 321 (defun make-c-file-name (output-defaults &optional suffix)
 322   (make-pathname :type "c"
 323                  :name (strcat (pathname-name output-defaults) suffix)
 324                  :defaults output-defaults))
 325
 326 (defun make-o-file-name (output-defaults &optional suffix)
 327   (make-pathname :type (bundle-pathname-type :object)
 328                  :name (format nil "~A~@[~A~]" (pathname-name output-defaults) suffix)
 329                  :defaults output-defaults))
 330
 331 (defun make-so-file-name (defaults)
 332   (make-pathname :type (bundle-pathname-type :shared-library)
 333                  :defaults defaults))
 334
 335 (defun make-exe-file-name (defaults)
 336   (make-pathname :type (bundle-pathname-type :program)
 337                  :defaults defaults))
 338
 339
 340 ;;; Implement link-op on image-based platforms.
 341 #-(or clasp ecl mkcl)
 342 (defmethod perform ((o link-op) (c system))
 343   (let* ((inputs (input-files o c))
 344          (output (first (output-files o c)))
 345          (kind (bundle-type o)))
 346     (when output ;; some operations skip any output when there is no input
 347       (ecase kind
 348         (:program (link-executable output inputs))
 349         ((:lib :static-library) (link-static-library output inputs))
 350         ((:dll :shared-library) (link-shared-library output inputs))))))
 351
 352 (defclass c-file (source-file)
 353   ((cflags :initarg :cflags :initform :default)
 354    (type :initform "c")))
 355
 356 (defmethod output-files ((o compile-op) (c c-file))
 357   (let* ((i (first (input-files o c)))
 358          (base (format nil "~(~{~a~^__~}~)"
 359                        (mapcar (lambda (x) (substitute-if #\_ (complement #'alphanumericp) x))
 360                                (component-find-path c))))
 361          (path (make-pathname :defaults i :name base)))
 362     (list (make-o-file-name path)
 363           (make-so-file-name path))))
 364
 365 (defmethod perform ((o compile-op) (c c-file))
 366   (let ((i (first (input-files o c))))
 367     (destructuring-bind (.o .so) (output-files o c)
 368       (cc-compile .o (list i))
 369       (link-shared-library .so (list .o)))))
 370
 371 (defmethod perform ((o load-op) (c c-file))
 372   (let ((o (second (input-files o c))))
 373     (cffi:load-foreign-library (file-namestring o) :search-path (list (pathname-directory-pathname o)))))
 374
 375 (setf (find-class 'asdf::c-file) (find-class 'c-file))
 376
 377 (defclass o-file (source-file)
 378   ((cflags :initarg :cflags :initform :default)
 379    (type :initform (bundle-pathname-type :object)))
 380   (:documentation "class for pre-compile object components"))
 381
 382 (defmethod output-files ((op compile-op) (c o-file))
 383   (let* ((o (first (input-files op c)))
 384          (so (apply-output-translations (make-so-file-name o))))
 385     (values (list o so) t)))
 386
 387 (defmethod perform ((o load-op) (c o-file))
 388   (let ((so (second (input-files o c))))
 389     (cffi:load-foreign-library (file-namestring so) :search-path (list (pathname-directory-pathname so)))))
 390
 391 (setf (find-class 'asdf::o-file) (find-class 'o-file))
 392