/[cmucl]/src/code/foreign.lisp
ViewVC logotype

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.50.4.1 - (show annotations)
Tue Jun 21 17:42:54 2005 UTC (8 years, 9 months ago) by rtoy
Branch: release-19b-branch
Changes since 1.50: +2 -2 lines
Merge from HEAD:

code/foreign.lisp:
o Support logical pathnames in load-foreign.

compiler/ppc/macros.lisp:
o Fix bug in checking for pseudo-atomic interrupted bit.

docs/cmu-user/aliens.tex:
o Fix missing &body in definition of def-callback.

docs/cmu-user/internet.tex:
o Add docs for datagram networking.

tools/build.sh
o Remove sh -x that we don't really need.
1 ;;; -*- Package: SYSTEM -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/foreign.lisp,v 1.50.4.1 2005/06/21 17:42:54 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 (in-package "SYSTEM")
13
14 (in-package "ALIEN")
15 (export '(load-foreign))
16 (in-package "SYSTEM")
17 (import 'alien:load-foreign)
18
19 #+sparc (defconstant foreign-segment-start #xe0000000)
20 #+sparc (defconstant foreign-segment-size #x00100000)
21
22 #+hppa (defconstant foreign-segment-start #x10C00000)
23 #+hppa (defconstant foreign-segment-size #x00400000)
24
25 #+(and bsd x86)
26 (defconstant foreign-segment-start #x0E000000)
27 #+(and bsd x86)
28 (defconstant foreign-segment-size #x02000000)
29
30 (defvar *previous-linked-object-file* nil)
31 #-(or linux bsd svr4 irix)
32 (defvar *foreign-segment-free-pointer* foreign-segment-start)
33
34 (defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C"))
35 (let ((code (char-code #\A)))
36 (loop
37 (let ((name (format nil base (unix:unix-getpid) (code-char code))))
38 (multiple-value-bind
39 (fd errno)
40 (unix:unix-open name
41 (logior unix:o_wronly unix:o_creat unix:o_excl)
42 #o666)
43 (cond ((not (null fd))
44 (unix:unix-close fd)
45 (return name))
46 ((not (= errno unix:eexist))
47 (error "Could not create temporary file ~S: ~A"
48 name (unix:get-unix-error-msg errno)))
49
50 ((= code (char-code #\Z))
51 (setf code (char-code #\a)))
52 ((= code (char-code #\z))
53 (return nil))
54 (t
55 (incf code))))))))
56
57 #+(or (and FreeBSD (not elf)) (and sparc (not svr4)))
58 (alien:def-alien-type exec
59 (alien:struct nil
60 (magic c-call:unsigned-long)
61 (text c-call:unsigned-long)
62 (data c-call:unsigned-long)
63 (bss c-call:unsigned-long)
64 (syms c-call:unsigned-long)
65 (entry c-call:unsigned-long)
66 (trsize c-call:unsigned-long)
67 (drsize c-call:unsigned-long)))
68
69 #-(or linux bsd svr4)
70 (defun allocate-space-in-foreign-segment (bytes)
71 (let* ((pagesize-1 (1- (get-page-size)))
72 (memory-needed (logandc2 (+ bytes pagesize-1) pagesize-1))
73 (addr (int-sap *foreign-segment-free-pointer*))
74 (new-ptr (+ *foreign-segment-free-pointer* memory-needed)))
75 (when (> new-ptr (+ foreign-segment-start foreign-segment-size))
76 (error "Not enough memory left."))
77 (setf *foreign-segment-free-pointer* new-ptr)
78 (allocate-system-memory-at addr memory-needed)
79 addr))
80
81
82 ;;; ELF object file loading. Note that the conditionalization is
83 ;;; assuming that all of Linux/x86, Linux/Alpha, FreeBSD/x86,
84 ;;; OpenBSD/x86, and Solaris ports support ELF.
85 ;;;
86 ;;; The following definitions are taken from
87 ;;; /usr/include/sys/elf_common.h and /usr/include/sys/elf32.h.
88 ;;;
89 #+(or linux (and bsd (not darwin)) svr4)
90 (progn
91 (alien:def-alien-type elf-address (alien:unsigned 32))
92 (alien:def-alien-type elf-half-word (alien:unsigned 16))
93 (alien:def-alien-type elf-offset (alien:unsigned 32))
94 (alien:def-alien-type elf-signed-word (alien:integer 32))
95 (alien:def-alien-type elf-word (alien:unsigned 32))
96 (alien:def-alien-type elf-size (alien:unsigned 32))
97
98 (alien:def-alien-type eheader
99 ;;"Elf file header."
100 (alien:struct nil
101 (elf-ident (alien:array (alien:unsigned 8) 16))
102 (elf-type elf-half-word)
103 (elf-machine elf-half-word)
104 (elf-version elf-word)
105 (elf-entry elf-address)
106 (elf-program-header-offset elf-offset)
107 (elf-section-header-offset elf-offset)
108 (elf-flags elf-word)
109 (elf-header-size elf-half-word)
110 (elf-program-header-entry-size elf-half-word)
111 (elf-program-header-count elf-half-word)
112 (elf-section-header-entry-size elf-half-word)
113 (elf-section-header-count elf-half-word)
114 (elf-section-name-strings elf-half-word)))
115
116 ;; Indices into the elf-ident array, as per SVR4 ABI
117 (defconstant ei-mag0 0) ; Magic number, byte 0
118 (defconstant ei-mag1 1) ; Magic number, byte 1
119 (defconstant ei-mag2 2) ; Magic number, byte 2
120 (defconstant ei-mag3 3) ; Magic number, byte 3
121 (defconstant ei-class 4) ; class of machine
122 (defconstant ei-data 5) ; data format
123 (defconstant ei-version 6) ; ELF format version
124 (defconstant ei-osabi 7) ; Operating system / ABI identification
125 (defconstant ei-abiversion 8) ; ABI version
126 (defconstant ei-pad 9) ; Start of padding
127 (defconstant ei-nident 16) ; Size of elf-ident array
128
129 ;; values for elf-type
130 (defconstant et-relocatable 1)
131 (defconstant et-executable 2)
132 (defconstant et-shared-object 3)
133 (defconstant et-core-file 4)
134
135 ;; values for elf-ident[ei-osabi]
136 (defconstant elfosabi-sysv 0)
137 (defconstant elfosabi-hpux 1)
138 (defconstant elfosabi-netbsd 2)
139 (defconstant elfosabi-linux 3)
140 (defconstant elfosabi-hurd 4)
141 (defconstant elfosabi-86open 5)
142 (defconstant elfosabi-solaris 6)
143 (defconstant elfosabi-monterey 7)
144 (defconstant elfosabi-irix 8)
145 (defconstant elfosabi-freebsd 9)
146 (defconstant elfosabi-tru64 10)
147 (defconstant elfosabi-modesto 11)
148 (defconstant elfosabi-openbsd 12)
149 (defconstant elfosabi-arm 97)
150 (defconstant elfosabi-standalone 255)
151
152 (alien:def-alien-type pheader
153 ;;"Program header."
154 (alien:struct nil
155 (p-type elf-word) ; Entry type.
156 (p-offset elf-offset) ; File offset of contents.
157 (p-virtual-address elf-address) ; Virtual address in mem. image.
158 (p-physical-address elf-address) ; Physical address (not used).
159 (p-file-size elf-size) ; Size of contents in file.
160 (p-memory-size elf-size) ; Size of contents in memory.
161 (p-flags elf-word) ; Access permission flags.
162 (p-alignment elf-size))) ; Alignment in memory and file.
163
164 (defconstant +elf-magic+
165 (make-array 4 :element-type '(unsigned-byte 8)
166 :initial-contents '(127 69 76 70))) ; 0x7f-E-L-F
167 (defun elf-p (h)
168 "Make sure the header starts with the ELF magic value."
169 (dotimes (i 4 t)
170 (unless (= (alien:deref h i) (aref +elf-magic+ i))
171 (return nil))))
172
173 (defun elf-osabi (h)
174 "Return the `osabi' field in the padding of the ELF file."
175 (alien:deref h ei-osabi))
176
177 (defun elf-osabi-name (id)
178 (cond
179 ((eql id elfosabi-sysv) "Unix System V ABI")
180 ((eql id elfosabi-hpux) "HP-UX")
181 ((eql id elfosabi-netbsd) "NetBSD")
182 ((eql id elfosabi-linux) "Linux")
183 ((eql id elfosabi-hurd) "GNU/Hurd")
184 ((eql id elfosabi-86open) "86Open common IA32 ABI")
185 ((eql id elfosabi-solaris) "Solaris")
186 ((eql id elfosabi-monterey) "Monterey")
187 ((eql id elfosabi-irix) "IRIX")
188 ((eql id elfosabi-freebsd) "FreeBSD")
189 ((eql id elfosabi-tru64) "Tru64 Unix")
190 ((eql id elfosabi-modesto) "Novell Modesto")
191 ((eql id elfosabi-openbsd) "OpenBSD")
192 ((eql id elfosabi-arm) "ARM")
193 ((eql id elfosabi-standalone) "Standalone/Embedded")
194 (t (format nil "Unknown ABI (~D)" id))))
195
196 (defun elf-executable-p (n)
197 "Given a file type number, determine whether the file is executable."
198 (= n et-executable))
199
200 (defun file-shared-library-p (pathname)
201 (with-open-file (obj pathname
202 :direction :input
203 :element-type '(unsigned-byte 8))
204 (let ((fd (lisp::fd-stream-fd obj)))
205 (alien:with-alien ((header eheader))
206 (unix:unix-read fd (alien:alien-sap header) (alien:alien-size eheader :bytes))
207 (when (elf-p (alien:slot header 'elf-ident))
208 (eql et-shared-object (alien:slot header 'elf-type)))))))
209 ) ;; #+(or linux (and bsd (not darwin)) svr4)
210
211
212
213 ;; Darwin loading of foreign code. This uses the dlopen shims and thus
214 ;; appears like ELF to the rest of the code in this file. However testing
215 ;; for shared libs obviously needs to test for Mach-O dylibs, and not
216 ;; ELF shared libraries...
217 #+darwin
218 (progn
219
220 (alien:def-alien-type machheader
221 (alien:struct nil
222 (magic (alien:unsigned 32))
223 (cputype (alien:signed 32))
224 (cpusubtype (alien:signed 32))
225 (filetype (alien:unsigned 32))
226 (ncmds (alien:unsigned 32))
227 (sizeofcmds (alien:unsigned 32))
228 (flags (alien:unsigned 32))))
229
230 ;; values for magic
231 (defconstant mh-magic #xfeedface)
232
233 ;; values for filetype
234 (defconstant mh-object #x1)
235 (defconstant mh-execute #x2)
236 (defconstant mh-fvmlib #x3)
237 (defconstant mh-core #x4)
238 (defconstant mh-preload #x5)
239 (defconstant mh-dylib #x6)
240 (defconstant mh-dylinker #x7)
241 (defconstant mh-bundle #x8)
242 (defconstant mh-dylib-stub #x9)
243
244 (defun mach-o-p (h)
245 "Make sure the header starts with the mach-o magic value."
246 (eql (alien:slot h 'magic) mh-magic))
247
248 (defun file-shared-library-p (pathname)
249 (with-open-file (obj pathname
250 :direction :input
251 :element-type '(unsigned-byte 8))
252 (let ((fd (lisp::fd-stream-fd obj)))
253 (alien:with-alien ((header machheader))
254 (unix:unix-read fd (alien:alien-sap header)
255 (alien:alien-size machheader :bytes))
256 (when (mach-o-p header)
257 (or (eql mh-dylib (alien:slot header 'filetype))
258 (eql mh-bundle (alien:slot header 'filetype))))))))
259 ) ; #+darwin
260
261
262
263 ;; "old-style" loading of foreign code. This involves calling a
264 ;; platform-specific script that is installed as
265 ;; library:load-foreign.csh to convert the object files into a form
266 ;; that is suitable for being stuffed into memory at runtime.
267 #-(or linux bsd svr4)
268 (progn
269 (defun load-object-file (name)
270 ;; NAME designates a tempory file created by ld via "load-foreign.csh".
271 ;; Its contents are in a form suitable for stuffing into memory for
272 ;; execution. This function extracts the location and size of the
273 ;; relevant bits and reads them into memory.
274
275 #|| library:load-foreign.csh
276 #!/bin/csh -fx
277 ld -N -R $argv[1] -Ttext $argv[2] -o $argv[3] $argv[5-]
278 if ($status != 0) exit 1
279
280 nm -gp $argv[3] > $argv[4]
281 if ($status != 0) exit 2
282 exit 0
283 ||#
284
285 (format t ";;; Loading object file...~%")
286 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
287 (unless fd
288 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
289 (unwind-protect
290 (alien:with-alien ((header eheader))
291 (unix:unix-read fd
292 (alien:alien-sap header)
293 (alien:alien-size eheader :bytes))
294 (unless (elf-p (alien:slot header 'elf-ident))
295 (error (format nil "~A is not an ELF file." name)))
296
297 (let ((osabi (elf-osabi (alien:slot header 'elf-ident)))
298 (expected-osabi #+NetBSD elfosabi-netbsd
299 #+FreeBSD elfosabi-freebsd))
300 (unless (= osabi expected-osabi)
301 (error "~A is not a ~A executable, it's a ~A executable."
302 name
303 (elf-osabi-name expected-osabi)
304 (elf-osabi-name osabi))))
305
306 (unless (elf-executable-p (alien:slot header 'elf-type))
307 (error (format nil "~A is not executable." name)))
308
309 (alien:with-alien ((program-header pheader))
310 (unix:unix-read fd
311 (alien:alien-sap program-header)
312 (alien:alien-size pheader :bytes))
313 (let* ((addr (system::allocate-space-in-foreign-segment
314 (alien:slot program-header 'p-memory-size))))
315 (unix:unix-lseek
316 fd (alien:slot program-header 'p-offset) unix:l_set)
317 (unix:unix-read
318 fd addr (alien:slot program-header 'p-file-size)))))
319 (unix:unix-close fd))))
320
321 (defun parse-symbol-table (name)
322 "Parse symbol table file created by load-foreign script. Modified
323 to skip undefined symbols which don't have an address."
324 (format t ";;; Parsing symbol table...~%")
325 (let ((symbol-table (make-hash-table :test #'equal)))
326 (with-open-file (file name)
327 (loop
328 (let ((line (read-line file nil nil)))
329 (unless line
330 (return))
331 (unless (eql (aref line 0) #\space) ; Skip undefined symbols....
332 (let* ((symbol (subseq line 11))
333 (address (parse-integer line :end 8 :radix 16))
334 (kind (aref line 9)) ; filter out .o file names
335 (old-address (gethash symbol lisp::*foreign-symbols*)))
336 (unless (or (null old-address) (= address old-address)
337 (char= kind #\F))
338 (warn "~S moved from #x~8,'0X to #x~8,'0X.~%"
339 symbol old-address address))
340 (setf (gethash symbol symbol-table) address))))))
341 (setf lisp::*foreign-symbols* symbol-table)))
342 ) ;; #-(or linux bsd svr4)
343
344
345
346 ;;; pw-- This seems to work for FreeBSD. The MAGIC field is not tested
347 ;;; for correct file format so it may croak if ld fails to produce the
348 ;;; expected results. It is probably good enough for now.
349 #+(or (and FreeBSD (not ELF)) (and sparc (not svr4)))
350 (defun load-object-file (name)
351 (format t ";;; Loading object file...~%")
352 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
353 (unless fd
354 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
355 (unwind-protect
356 (alien:with-alien ((header exec))
357 (unix:unix-read fd
358 (alien:alien-sap header)
359 (alien:alien-size exec :bytes))
360 (let* ((len-of-text-and-data
361 (+ (alien:slot header 'text) (alien:slot header 'data)))
362 (memory-needed
363 (+ len-of-text-and-data (alien:slot header 'bss)))
364 (addr (allocate-space-in-foreign-segment memory-needed)))
365 (unix:unix-read fd addr len-of-text-and-data)))
366 (unix:unix-close fd))))
367
368
369 #+hppa
370 (alien:def-alien-type nil
371 (alien:struct sys_clock
372 (secs c-call:unsigned-int)
373 (nanosecs c-call:unsigned-int)))
374 #+hppa
375 (alien:def-alien-type nil
376 (alien:struct header
377 (system_id c-call:short)
378 (a_magic c-call:short)
379 (version_id c-call:unsigned-int)
380 (file_time (alien:struct sys_clock))
381 (entry_space c-call:unsigned-int)
382 (entry_subspace c-call:unsigned-int)
383 (entry_offset c-call:unsigned-int)
384 (aux_header_location c-call:unsigned-int)
385 (aux_header_size c-call:unsigned-int)
386 (som_length c-call:unsigned-int)
387 (presumed_dp c-call:unsigned-int)
388 (space_location c-call:unsigned-int)
389 (space_total c-call:unsigned-int)
390 (subspace_location c-call:unsigned-int)
391 (subspace_total c-call:unsigned-int)
392 (loader_fixup_location c-call:unsigned-int)
393 (loader_fixup_total c-call:unsigned-int)
394 (space_strings_location c-call:unsigned-int)
395 (space_strings_size c-call:unsigned-int)
396 (init_array_location c-call:unsigned-int)
397 (init_array_total c-call:unsigned-int)
398 (compiler_location c-call:unsigned-int)
399 (compiler_total c-call:unsigned-int)
400 (symbol_location c-call:unsigned-int)
401 (symbol_total c-call:unsigned-int)
402 (fixup_request_location c-call:unsigned-int)
403 (fixup_request_total c-call:unsigned-int)
404 (symbol_strings_location c-call:unsigned-int)
405 (symbol_strings_size c-call:unsigned-int)
406 (unloadable_sp_location c-call:unsigned-int)
407 (unloadable_sp_size c-call:unsigned-int)
408 (checksum c-call:unsigned-int)))
409
410 #+hppa
411 (alien:def-alien-type nil
412 (alien:struct aux_id
413 #|
414 (mandatory c-call:unsigned-int 1)
415 (copy c-call:unsigned-int 1)
416 (append c-call:unsigned-int 1)
417 (ignore c-call:unsigned-int 1)
418 (reserved c-call:unsigned-int 12)
419 (type c-call:unsigned-int 16)
420 |#
421 (dummy c-call:unsigned-int)
422 (length c-call:unsigned-int)))
423 #+hppa
424 (alien:def-alien-type nil
425 (alien:struct som_exec_auxhdr
426 (som_auxhdr (alien:struct aux_id))
427 (exec_tsize c-call:long)
428 (exec_tmem c-call:long)
429 (exec_tfile c-call:long)
430 (exec_dsize c-call:long)
431 (exec_dmem c-call:long)
432 (exec_dfile c-call:long)
433 (exec_bsize c-call:long)
434 (exec_entry c-call:long)
435 (exec_flags c-call:long)
436 (exec_bfill c-call:long)))
437
438 #+hppa
439 (alien:def-alien-routine ("bzero" unix-bzero) c-call:void
440 (s alien:system-area-pointer)
441 (n c-call:unsigned-long))
442
443 #+hppa
444 (defconstant reloc-magic #x106)
445 #+hppa
446 (defconstant cpu-pa-risc1-0 #x20b)
447 #+hppa
448 (defconstant cpu-pa-risc1-1 #x210)
449 #+hppa
450 (defconstant cpu-pa-risc-max #x2ff)
451
452 #+hppa
453 (defun load-object-file (name)
454 (format t ";;; Loading object file...~%")
455 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
456 (unless fd
457 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
458 (unwind-protect
459 (alien:with-alien ((header (alien:struct som_exec_auxhdr)))
460 (unix:unix-lseek fd (alien:alien-size (alien:struct header) :bytes)
461 unix:l_set)
462 (unix:unix-read fd
463 (alien:alien-sap header)
464 (alien:alien-size (alien:struct som_exec_auxhdr)
465 :bytes))
466 (let* ((tmem (alien:slot header 'exec_tmem))
467 (tsize (alien:slot header 'exec_tsize))
468 (dmem (alien:slot header 'exec_dmem))
469 (dsize (alien:slot header 'exec_dsize))
470 (bsize (alien:slot header 'exec_bsize))
471 (memory-needed (+ tsize dsize bsize (* 2 4096)))
472 (addr (allocate-space-in-foreign-segment memory-needed)))
473 (unix-bzero addr memory-needed) ;force valid
474 (unix:unix-lseek fd (alien:slot header 'exec_tfile) unix:l_set)
475 (unix:unix-read fd (system:int-sap tmem) tsize)
476 (unix:unix-lseek fd (alien:slot header 'exec_dfile) unix:l_set)
477 (unix:unix-read fd (system:int-sap dmem) dsize)
478 (unix-bzero (system:int-sap (+ dmem dsize)) bsize)
479 ;;(format t "tmem ~X tsize ~X dmem ~X dsize ~X bsize ~X~%"
480 ;; tmem tsize dmem dsize bsize)
481 ;;(format t "tfile ~X dfile ~X~%"
482 ;; (alien:slot header 'exec_tfile)
483 ;; (alien:slot header 'exec_dfile))
484 (alien:alien-funcall (alien:extern-alien
485 "sanctify_for_execution"
486 (alien:function c-call:void
487 alien:system-area-pointer
488 c-call:unsigned-long))
489 addr (+ (- dmem tmem) dsize bsize))
490 ))
491 (unix:unix-close fd))))
492
493 #-(or linux bsd solaris irix)
494 (progn
495 (defun parse-symbol-table (name)
496 (format t ";;; Parsing symbol table...~%")
497 (let ((symbol-table (make-hash-table :test #'equal)))
498 (with-open-file (file name)
499 (loop
500 (let ((line (read-line file nil nil)))
501 (unless line
502 (return))
503 (let* ((symbol (subseq line 11))
504 (address (parse-integer line :end 8 :radix 16))
505 #+BSD (kind (aref line 9)) ; filter out .o file names
506 (old-address (gethash symbol lisp::*foreign-symbols*)))
507 (unless (or (null old-address) (= address old-address)
508 #+BSD (char= kind #\F))
509 (warn "~S moved from #x~8,'0X to #x~8,'0X.~%"
510 symbol old-address address))
511 (setf (gethash symbol symbol-table) address)))))
512 (setf lisp::*foreign-symbols* symbol-table)))
513
514 (defun load-foreign (files &key
515 (libraries '("-lc"))
516 (base-file
517 #-hpux
518 (merge-pathnames *command-line-utility-name*
519 "path:")
520 #+hpux "library:cmucl.orig")
521 (env ext:*environment-list*)
522 (verbose *load-verbose*))
523 "Load-foreign loads a list of C object files into a running Lisp. The files
524 argument should be a single file or a list of files. The files may be
525 specified as namestrings or as pathnames. The libraries argument should be a
526 list of library files as would be specified to ld. They will be searched in
527 the order given. The default is just \"-lc\", i.e., the C library. The
528 base-file argument is used to specify a file to use as the starting place for
529 defined symbols. The default is the C start up code for Lisp. The env
530 argument is the Unix environment variable definitions for the invocation of
531 the linker. The default is the environment passed to Lisp."
532 (let ((output-file (pick-temporary-file-name))
533 (symbol-table-file (pick-temporary-file-name))
534 (error-output (make-string-output-stream))
535 (files (if (atom files) (list files) files)))
536
537 (when verbose
538 (format t ";;; Running library:load-foreign.csh...~%")
539 (force-output))
540 #+hpux
541 (dolist (f files)
542 (with-open-file (stream f :element-type '(unsigned-byte 16))
543 (unless (let ((sysid (read-byte stream)))
544 (or (eql sysid cpu-pa-risc1-0)
545 (and (>= sysid cpu-pa-risc1-1)
546 (<= sysid cpu-pa-risc-max))))
547 (error "Object file is wrong format, so can't load-foreign:~
548 ~% ~S"
549 f))
550 (unless (eql (read-byte stream) reloc-magic)
551 (error "Object file is not relocatable, so can't load-foreign:~
552 ~% ~S"
553 f))))
554
555 (let ((proc (ext:run-program
556 "library:load-foreign.csh"
557 (list* (or *previous-linked-object-file*
558 (namestring (truename base-file)))
559 (format nil "~X"
560 *foreign-segment-free-pointer*)
561 output-file
562 symbol-table-file
563 (append (mapcar
564 #'(lambda (name)
565 (or (unix-namestring name)
566 (error 'simple-file-error
567 :pathname name
568 :format-control
569 "File does not exist: ~A."
570 :format-arguments
571 (list name))))
572
573 files)
574 libraries))
575 :env env
576 :input nil
577 :output error-output
578 :error :output)))
579 (unless proc
580 (error "Could not run library:load-foreign.csh"))
581 (unless (zerop (ext:process-exit-code proc))
582 (system:serve-all-events 0)
583 (error "library:load-foreign.csh failed:~%~A"
584 (get-output-stream-string error-output)))
585 (load-object-file output-file)
586 (parse-symbol-table symbol-table-file)
587 (unix:unix-unlink symbol-table-file)
588 (let ((old-file *previous-linked-object-file*))
589 (setf *previous-linked-object-file* output-file)
590 (when old-file
591 (unix:unix-unlink old-file)))))
592 (when verbose
593 (format t ";;; Done.~%")
594 (force-output)))
595
596
597 (export '(alternate-get-global-address))
598
599 (defun alternate-get-global-address (symbol)
600 (declare (type simple-string symbol)
601 (ignore symbol))
602 0)
603 ) ;; #-(or linux bsd solaris irix)
604
605
606 ;; Modern dlopen()-based loading of shared libraries
607 #+(or linux bsd solaris irix)
608 (progn
609
610 (defconstant rtld-lazy 1
611 "Lazy function call binding")
612 (defconstant rtld-now 2
613 "Immediate function call binding")
614 #+(and linux glibc2)
615 (defconstant rtld-binding-mask #x3
616 "Mask of binding time value")
617
618 (defconstant rtld-global #-irix #x100 #+irix 4
619 "If set the symbols of the loaded object and its dependencies are
620 made visible as if the object were linked directly into the program")
621
622 (defvar *global-table* nil)
623 ;;; Dynamically loaded stuff isn't there upon restoring from a
624 ;;; save--this is primarily for irix, which resolves tzname at
625 ;;; runtime, resulting in *global-table* being set in the saved core
626 ;;; image, resulting in havoc upon restart.
627 #-linkage-table
628 (pushnew #'(lambda () (setq *global-table* nil))
629 ext:*after-save-initializations*)
630
631 (defvar *dso-linker*
632 #+solaris "/usr/ccs/bin/ld"
633 #-solaris "/usr/bin/ld")
634
635 (alien:def-alien-routine dlopen system-area-pointer
636 (file c-call:c-string) (mode c-call:int))
637 (alien:def-alien-routine dlsym system-area-pointer
638 (lib system-area-pointer)
639 (name c-call:c-string))
640 (alien:def-alien-routine dlclose void (lib system-area-pointer))
641 (alien:def-alien-routine dlerror c-call:c-string)
642
643 ;;; Ensure we've opened our own binary so can resolve global variables
644 ;;; in the lisp image that come from libraries. This used to happen
645 ;;; only in alternate-get-global-address, and only if no libraries
646 ;;; were dlopened already, but that didn't work if something was
647 ;;; dlopened before any problem global vars were used. So now we do
648 ;;; this in any function that can add to the global-table, as well as
649 ;;; in alternate-get-global-address.
650 (defun ensure-lisp-table-opened ()
651 (unless *global-table*
652 ;; Prevent recursive call if dlopen isn't defined
653 (setf *global-table* (acons (int-sap 0) nil nil))
654 (setf *global-table* (acons (dlopen nil rtld-lazy) nil nil))
655 (when (zerop (system:sap-int (caar *global-table*)))
656 (error "Can't open global symbol table: ~S" (dlerror)))))
657
658 (defun load-object-file (file)
659 (ensure-lisp-table-opened)
660 ; rtld global: so it can find all the symbols previously loaded
661 ; rtld now: that way dlopen will fail if not all symbols are defined.
662 (let* ((filename (namestring (truename file)))
663 (sap (dlopen filename (logior rtld-now rtld-global))))
664 (cond ((zerop (sap-int sap))
665 (let ((err-string (dlerror))
666 (sap (dlopen filename (logior rtld-lazy rtld-global))))
667 ;; For some reason dlerror always seems to return NIL,
668 ;; which isn't very informative.
669 (when (zerop (sap-int sap))
670 (error "Can't open object ~S: ~S" file err-string))
671 (dlclose sap)
672 (error "LOAD-OBJECT-FILE: Unresolved symbols in file ~S: ~S"
673 file err-string)))
674 ((null (assoc sap *global-table* :test #'sap=))
675 (setf *global-table* (acons sap file *global-table*)))
676 (t nil))))
677
678 ;;; Clear close all dlopened libraries and clear out the entries in
679 ;;; *global-table*, prior to doing a save-lisp.
680
681 (defun close-global-table ()
682 (loop for lib-entry in *global-table*
683 for (sap) = lib-entry
684 do (progn
685 (dlclose sap)
686 ;; Probably not necessary, but neater than leaving around
687 ;; stale handles in the saved image.
688 (setf (car lib-entry) (int-sap 0)))))
689
690 ;;; Open all the libraries in *GLOBAL-TABLE*. We open them in the same
691 ;;; order as the first time they were loaded, so that any dependencies
692 ;;; on load order are respected.
693 (defun reinitialize-global-table ()
694 (loop for lib-entry in (reverse *global-table*)
695 for (sap . lib-path) = lib-entry
696 when lib-path
697 do (let ((new-sap (dlopen (namestring lib-path)
698 (logior rtld-now rtld-global))))
699 (when (zerop (sap-int new-sap))
700 ;; We're going down
701 (error "Couldn't open library ~S: ~S" lib-path (dlerror)))
702 (setf (car lib-entry) new-sap)))
703 (alien:alien-funcall (alien:extern-alien "os_resolve_data_linkage"
704 (alien:function c-call:void))))
705
706 (defun alternate-get-global-address (symbol)
707 (ensure-lisp-table-opened)
708 ;; find the symbol in any of the loaded objects,
709 ;; search in reverse order of loading, later loadings
710 ;; take precedence
711 (let ((result 0))
712 (do ((table *global-table* (cdr table)))
713 ((or (null (car table)) (not (zerop result))))
714 (setq result (sap-int (dlsym (caar table) symbol))))
715 (values result)))
716
717 (defun load-foreign (files &key
718 (libraries '("-lc"))
719 (base-file nil)
720 (env ext:*environment-list*)
721 (verbose *load-verbose*))
722 "Load C object files into the running Lisp. The FILES argument
723 should be a single file or a list of files. The files may be specified
724 as namestrings or as pathnames. The LIBRARIES argument should be a
725 list of library files as would be specified to ld. They will be
726 searched in the order given. The default is just \"-lc\", i.e., the C
727 library. The BASE-FILE argument is used to specify a file to use as
728 the starting place for defined symbols. The default is the C start up
729 code for Lisp. The ENV argument is the Unix environment variable
730 definitions for the invocation of the linker. The default is the
731 environment passed to Lisp."
732 ;; Note: dlopen remembers the name of an object, when dlopenin
733 ;; the same name twice, the old objects is reused.
734 (declare (ignore base-file))
735 ;; if passed a single shared object that can be loaded directly via
736 ;; dlopen(), do that instead of using the linker
737 (cond ((and (atom files)
738 (probe-file files)
739 (file-shared-library-p files))
740 (when verbose
741 (format t ";;; Opening shared library ~A ...~%" files))
742 (load-object-file files)
743 (when verbose
744 (format t ";;; Done.~%")))
745 (t
746 (let ((output-file (pick-temporary-file-name
747 (concatenate 'string "/tmp/~D~C" (string (gensym)))))
748 (error-output (make-string-output-stream)))
749
750 (when verbose
751 (format t ";;; Running ~A...~%" *dso-linker*)
752 (force-output))
753
754 (let ((proc (ext:run-program
755 *dso-linker*
756 (list*
757 #+(or solaris linux FreeBSD4) "-G"
758 #+(or OpenBSD NetBSD irix) "-shared"
759 #+darwin "-dylib"
760 "-o"
761 output-file
762 ;; Cause all specified libs to be loaded in full
763 #+(or OpenBSD linux FreeBSD4 NetBSD) "--whole-archive"
764 #+solaris "-z" #+solaris "allextract"
765 #+darwin "-all_load"
766 (append (mapcar
767 #'(lambda (name)
768 (or (unix-namestring name)
769 (error 'simple-file-error
770 :pathname name
771 :format-control
772 "File does not exist: ~A."
773 :format-arguments
774 (list name))))
775 (if (atom files)
776 (list files)
777 files))
778 ;; Return to default ld behaviour for libs
779 (list
780 #+(or OpenBSD linux FreeBSD4 NetBSD)
781 "--no-whole-archive"
782 #+solaris "-z" #+solaris "defaultextract")
783 libraries))
784 ;; on Linux/AMD64, we need to tell the platform linker to use the 32-bit
785 ;; linking mode instead of the default 64-bit mode. This can be done either
786 ;; via the LDEMULATION environment variable, or via the "-m" command-line
787 ;; option. Here we assume that LDEMULATION will be ignored by the platform
788 ;; linker on Linux/i386 platforms.
789 :env `(#+(and x86 linux) (:ldemulation . "elf_i386") ,@env)
790 :input nil
791 :output error-output
792 :error :output)))
793 (unless proc
794 (error "Could not run ~A" *dso-linker*))
795 (unless (zerop (ext:process-exit-code proc))
796 (system:serve-all-events 0)
797 (error "~A failed:~%~A" *dso-linker*
798 (get-output-stream-string error-output)))
799 (load-object-file output-file)
800 (unix:unix-unlink output-file)))
801 (when verbose
802 (format t ";;; Done.~%")
803 (force-output)))))
804
805 ) ;; #+(or linux bsd solaris irix)

  ViewVC Help
Powered by ViewVC 1.1.5