GopherProxy

	tc-toolchain.lisp - clic - Clic is an command line interactive client for gophe…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tc-toolchain.lisp (16218B)
	---
	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 #+bsd ,@`("ar" "rcs" ,output-file) ;; NB: includes darwin
	299 #+linux ,@`("ar" "rcsDT" ,output-file)
	300 #+windows ,@`("lib" "-nologo" ,(strcat "-out:" (native-name…
	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 input…
	312 :on-missing-lisp-object-initializer nil)
	313 #-(or ecl mkcl)
	314 ;; Don't use a temporary file, because linking is sensitive to the out…
	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-def…
	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 inp…
	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 #\_ (complemen…
	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 (p…
	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 (…
	390
	391 (setf (find-class 'asdf::o-file) (find-class 'o-file))
	392