77dd2192 |
1 | (in-package :asdf) |
2 | |
1a9c1e08 |
3 | (export 'load-dso) |
4 | |
77dd2192 |
5 | (defun concatenate-strings (strings &optional delimiter) |
6 | (if (not (rest strings)) |
7 | (first strings) |
8 | (concatenate |
9 | 'string |
10 | (first strings) |
11 | (if delimiter (string delimiter) "") |
12 | (concatenate-strings (rest strings) delimiter)))) |
13 | |
14 | ;;; The following code is more or less copied frm sb-bsd-sockets.asd, |
15 | ;;; but extended to allow flags set in a general way |
16 | |
17 | (defclass unix-dso (module) ()) |
18 | (defun unix-name (pathname) |
19 | (namestring |
20 | (typecase pathname |
21 | (logical-pathname (translate-logical-pathname pathname)) |
22 | (t pathname)))) |
23 | |
1a9c1e08 |
24 | (defmethod input-files ((operation compile-op) (dso unix-dso)) |
77dd2192 |
25 | (mapcar #'component-pathname (module-components dso))) |
26 | |
27 | (defmethod output-files ((operation compile-op) (dso unix-dso)) |
28 | (let ((dir (component-pathname dso))) |
29 | (list |
30 | (make-pathname :type "so" |
31 | :name (car (last (pathname-directory dir))) |
32 | :directory (butlast (pathname-directory dir)) |
33 | :defaults dir)))) |
34 | |
35 | |
36 | (defmethod perform :after ((operation compile-op) (dso unix-dso)) |
37 | (let ((dso-name (unix-name (car (output-files operation dso))))) |
38 | (unless (zerop |
39 | (run-shell-command |
40 | "gcc ~A -o ~S ~{~S ~}" |
41 | (concatenate 'string |
42 | ;; (sb-ext:posix-getenv "EXTRA_LDFLAGS") |
43 | ;; " " |
44 | #+sunos "-shared -lresolv -lsocket -lnsl" |
45 | #+darwin "-bundle" |
46 | #-(or darwin sunos) "-shared") |
47 | dso-name |
48 | (mapcar #'unix-name |
49 | (mapcan (lambda (c) |
50 | (output-files operation c)) |
51 | (module-components dso))))) |
52 | (error 'operation-error :operation operation :component dso)))) |
53 | |
1a9c1e08 |
54 | ;; Taken from foreign.lisp in the CMUCL tree, but modified to delay |
55 | ;; resolving of symbols until they are used |
56 | (defun load-dso (file) |
57 | (system::ensure-lisp-table-opened) |
58 | ; rtld global: so it can find all the symbols previously loaded |
59 | ; rtld lazy: that way dlopen will not fail if not all symbols are defined. |
60 | (let ((filename (namestring file))) |
61 | (format t ";;; Loading shared library ~A ...~%" filename) |
62 | (let ((sap (system::dlopen filename (logior system::rtld-lazy system::rtld-global)))) |
63 | (cond ((zerop (system:sap-int sap)) |
64 | (let ((err-string (system::dlerror))) |
65 | |
66 | ;; For some reason dlerror always seems to return NIL, |
67 | ;; which isn't very informative. |
68 | (error "Can't open object ~S: ~S" file err-string))) |
69 | ((null (assoc sap system::*global-table* :test #'system:sap=)) |
70 | (setf system::*global-table* (acons sap file system::*global-table*)) |
71 | t) |
72 | (t nil))))) |
73 | |
74 | |
77dd2192 |
75 | (defmethod perform ((o load-op) (c unix-dso)) |
76 | (let ((co (make-instance 'compile-op))) |
77 | (let ((filename (car (output-files co c)))) |
1a9c1e08 |
78 | (load-dso filename)))) |
77dd2192 |
79 | |
80 | |
81 | |
82 | (defclass c-source-file (source-file) |
83 | ((cflags :initform nil :initarg :cflags) |
84 | (optimization :initform 2 :initarg :optimization) |
85 | (definitions :initform nil :initarg :definitions) |
86 | (include-paths :initform nil :initarg :include-paths))) |
87 | |
88 | |
89 | (defmethod output-files ((op compile-op) (c c-source-file)) |
90 | (list |
91 | (make-pathname :type "o" :defaults |
92 | (component-pathname c)))) |
93 | |
94 | |
95 | (defmethod perform ((op compile-op) (c c-source-file)) |
96 | (unless |
97 | (= 0 (run-shell-command "gcc ~A -o ~S -c ~S" |
98 | (concatenate-strings |
99 | (append |
100 | (list "-fPIC") |
101 | (when (slot-value c 'optimization) |
102 | (list (format nil "-O~A" (slot-value c 'optimization)))) |
103 | (loop |
104 | for symbol in (slot-value c 'definitions) |
105 | collect (format nil "-D~A" symbol)) |
106 | (loop |
107 | for path in (slot-value c 'include-paths) |
108 | collect (format nil "-I~A" path)) |
109 | (slot-value c 'cflags)) |
110 | #\sp) |
111 | (unix-name (car (output-files op c))) |
112 | (unix-name (component-pathname c)))) |
113 | (error 'operation-error :operation op :component c))) |
114 | |
115 | |
116 | (defmethod perform ((operation load-op) (c c-source-file)) |
117 | t) |
118 | |
119 | |
1a9c1e08 |
120 | |
121 | (defclass library (static-file) |
122 | ((libdir :initarg :libdir))) |
123 | |
124 | |
125 | (defun relative-pathname (path) |
126 | (etypecase path |
127 | (cons path) |
128 | (string (if (char= #\/ (char path 0)) |
129 | (subseq path 1) |
130 | path)))) |
131 | |
132 | (defmethod component-pathname ((lib library)) |
133 | (make-pathname :type "so" |
134 | :name (component-name lib) |
135 | :directory (relative-pathname (slot-value lib 'libdir)))) |
136 | |
137 | (defmethod perform ((o load-op) (c library)) |
138 | (load-dso (component-pathname c))) |