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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5