3rdparties/software/cffi_0.21.0/toolchain/c-toolchain.lisp (16281 bytes)
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 #+darwin ,@`("libtool" "-static" "-o" ,output-file) 299 #+(:and bsd (:not darwin)) ,@`("ar" "rcs" ,output-file) 300 #+linux ,@`("ar" "rcsDT" ,output-file) 301 #+windows ,@`("lib" "-nologo" ,(strcat "-out:" (native-namestring output-file))) 302 ,@inputs)) 303 #-(or bsd linux windows) 304 (error "Not implemented on your system"))) 305 306 (defun link-shared-library (output-file inputs) 307 ;; remove the library so we won't possibly be overwriting 308 ;; the code of any existing process 309 (delete-file-if-exists output-file) 310 #+ecl (c::build-shared-library output-file :lisp-files inputs) 311 #+mkcl (compiler::build-shared-library 312 output-file :lisp-object-files (mapcar 'program-argument inputs) 313 :on-missing-lisp-object-initializer nil) 314 #-(or ecl mkcl) 315 ;; Don't use a temporary file, because linking is sensitive to the output file name :-/ (or put it in a temporary directory?) 316 (apply 'invoke *ld* "-o" output-file 317 (append *ld-dll-flags* inputs))) 318 319 320 ;;; Computing file names 321 322 (defun make-c-file-name (output-defaults &optional suffix) 323 (make-pathname :type "c" 324 :name (strcat (pathname-name output-defaults) suffix) 325 :defaults output-defaults)) 326 327 (defun make-o-file-name (output-defaults &optional suffix) 328 (make-pathname :type (bundle-pathname-type :object) 329 :name (format nil "~A~@[~A~]" (pathname-name output-defaults) suffix) 330 :defaults output-defaults)) 331 332 (defun make-so-file-name (defaults) 333 (make-pathname :type (bundle-pathname-type :shared-library) 334 :defaults defaults)) 335 336 (defun make-exe-file-name (defaults) 337 (make-pathname :type (bundle-pathname-type :program) 338 :defaults defaults)) 339 340 341 ;;; Implement link-op on image-based platforms. 342 #-(or clasp ecl mkcl) 343 (defmethod perform ((o link-op) (c system)) 344 (let* ((inputs (input-files o c)) 345 (output (first (output-files o c))) 346 (kind (bundle-type o))) 347 (when output ;; some operations skip any output when there is no input 348 (ecase kind 349 (:program (link-executable output inputs)) 350 ((:lib :static-library) (link-static-library output inputs)) 351 ((:dll :shared-library) (link-shared-library output inputs)))))) 352 353 (defclass c-file (source-file) 354 ((cflags :initarg :cflags :initform :default) 355 (type :initform "c"))) 356 357 (defmethod output-files ((o compile-op) (c c-file)) 358 (let* ((i (first (input-files o c))) 359 (base (format nil "~(~{~a~^__~}~)" 360 (mapcar (lambda (x) (substitute-if #\_ (complement #'alphanumericp) x)) 361 (component-find-path c)))) 362 (path (make-pathname :defaults i :name base))) 363 (list (make-o-file-name path) 364 (make-so-file-name path)))) 365 366 (defmethod perform ((o compile-op) (c c-file)) 367 (let ((i (first (input-files o c)))) 368 (destructuring-bind (.o .so) (output-files o c) 369 (cc-compile .o (list i)) 370 (link-shared-library .so (list .o))))) 371 372 (defmethod perform ((o load-op) (c c-file)) 373 (let ((o (second (input-files o c)))) 374 (cffi:load-foreign-library (file-namestring o) :search-path (list (pathname-directory-pathname o))))) 375 376 (setf (find-class 'asdf::c-file) (find-class 'c-file)) 377 378 (defclass o-file (source-file) 379 ((cflags :initarg :cflags :initform :default) 380 (type :initform (bundle-pathname-type :object))) 381 (:documentation "class for pre-compile object components")) 382 383 (defmethod output-files ((op compile-op) (c o-file)) 384 (let* ((o (first (input-files op c))) 385 (so (apply-output-translations (make-so-file-name o)))) 386 (values (list o so) t))) 387 388 (defmethod perform ((o load-op) (c o-file)) 389 (let ((so (second (input-files o c)))) 390 (cffi:load-foreign-library (file-namestring so) :search-path (list (pathname-directory-pathname so))))) 391 392 (setf (find-class 'asdf::o-file) (find-class 'o-file)) 393