c-toolchain.lisp - clic - Clic is an command line interactive client for gopher… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
c-toolchain.lisp (16281B) | |
--- | |
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 <[email protected]> | |
6 ;;; Copyright (C) 2005-2006, Emily Backes <[email protected]> | |
7 ;;; Copyright (C) 2007, Stelian Ionescu <[email protected]> | |
8 ;;; Copyright (C) 2007, Luis Oliveira <[email protected]> | |
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 … | |
63 (defparameter *ld-exe-flags* nil "flags for linking executables via *ld*… | |
64 (defparameter *ld-dll-flags* nil "flags for linking shared library via *… | |
65 (defparameter *linkkit-start* nil "flags for the implementation linkkit,… | |
66 (defparameter *linkkit-end* nil "flags for the implementation linkkit, e… | |
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) "/… | |
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 "mo… | |
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 '… | |
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 'e… | |
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 star… | |
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-a… | |
239 (with-temporary-file | |
240 (:pathname tmp :direction :output | |
241 :prefix (strcat (native-namestring (pathname-directory-pathname… | |
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… | |
249 &body body) | |
250 "Create an output file atomically, by executing the BODY while OUTPUT-… | |
251 is bound to a temporary file name, then atomically renaming that tempora… | |
252 `(call-with-temporary-output ,output-file-val (lambda (,output-file-va… | |
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 input… | |
275 :on-missing-lisp-object-initializer nil) | |
276 #+(and sbcl (not sb-linkable-runtime)) (error "Your SBCL doesn't suppo… | |
277 #-(or ecl mkcl) | |
278 (link-executable output-file `(,@*linkkit-start* ,@inputs ,@*linkkit-e… | |
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 input… | |
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, d… | |
292 ;; ar T seems to only be on Linux (means something differen… | |
293 ;; A MRI script might be more portable... not, only support… | |
294 ;; I couldn't get libtool to work, and it's not ubiquitous … | |
295 ;; ,@`("libtool" "--mode=link" ,*cc* ,@*cc-flags* "-static"… | |
296 ;; "Solution": never link .a's into further .a's, only link… | |
297 ;; which implied changes that are now the case in ASDF 3.2.… | |
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-name… | |
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 input… | |
313 :on-missing-lisp-object-initializer nil) | |
314 #-(or ecl mkcl) | |
315 ;; Don't use a temporary file, because linking is sensitive to the out… | |
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-def… | |
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 inp… | |
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 #\_ (complemen… | |
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 (p… | |
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 (… | |
391 | |
392 (setf (find-class 'asdf::o-file) (find-class 'o-file)) | |
393 |