c-toolchain.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) 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 <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