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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.49 - (show annotations)
Wed Jul 7 15:03:11 2004 UTC (9 years, 9 months ago) by rtoy
Branch: MAIN
CVS Tags: prm-before-macosx-merge-tag
Changes since 1.48: +4 -4 lines
Changes from Robert Swindells to support NetBSD.
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.49 2004/07/07 15:03:11 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 openbsd linux 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 bsd 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 bsd svr4)
210
211
212
213 ;; "old-style" loading of foreign code. This involves calling a
214 ;; platform-specific script that is installed as
215 ;; library:load-foreign.csh to convert the object files into a form
216 ;; that is suitable for being stuffed into memory at runtime.
217 #-(or linux bsd svr4)
218 (progn
219 (defun load-object-file (name)
220 ;; NAME designates a tempory file created by ld via "load-foreign.csh".
221 ;; Its contents are in a form suitable for stuffing into memory for
222 ;; execution. This function extracts the location and size of the
223 ;; relevant bits and reads them into memory.
224
225 #|| library:load-foreign.csh
226 #!/bin/csh -fx
227 ld -N -R $argv[1] -Ttext $argv[2] -o $argv[3] $argv[5-]
228 if ($status != 0) exit 1
229
230 nm -gp $argv[3] > $argv[4]
231 if ($status != 0) exit 2
232 exit 0
233 ||#
234
235 (format t ";;; Loading object file...~%")
236 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
237 (unless fd
238 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
239 (unwind-protect
240 (alien:with-alien ((header eheader))
241 (unix:unix-read fd
242 (alien:alien-sap header)
243 (alien:alien-size eheader :bytes))
244 (unless (elf-p (alien:slot header 'elf-ident))
245 (error (format nil "~A is not an ELF file." name)))
246
247 (let ((osabi (elf-osabi (alien:slot header 'elf-ident)))
248 (expected-osabi #+NetBSD elfosabi-netbsd
249 #+FreeBSD elfosabi-freebsd))
250 (unless (= osabi expected-osabi)
251 (error "~A is not a ~A executable, it's a ~A executable."
252 name
253 (elf-osabi-name expected-osabi)
254 (elf-osabi-name osabi))))
255
256 (unless (elf-executable-p (alien:slot header 'elf-type))
257 (error (format nil "~A is not executable." name)))
258
259 (alien:with-alien ((program-header pheader))
260 (unix:unix-read fd
261 (alien:alien-sap program-header)
262 (alien:alien-size pheader :bytes))
263 (let* ((addr (system::allocate-space-in-foreign-segment
264 (alien:slot program-header 'p-memory-size))))
265 (unix:unix-lseek
266 fd (alien:slot program-header 'p-offset) unix:l_set)
267 (unix:unix-read
268 fd addr (alien:slot program-header 'p-file-size)))))
269 (unix:unix-close fd))))
270
271 (defun parse-symbol-table (name)
272 "Parse symbol table file created by load-foreign script. Modified
273 to skip undefined symbols which don't have an address."
274 (format t ";;; Parsing symbol table...~%")
275 (let ((symbol-table (make-hash-table :test #'equal)))
276 (with-open-file (file name)
277 (loop
278 (let ((line (read-line file nil nil)))
279 (unless line
280 (return))
281 (unless (eql (aref line 0) #\space) ; Skip undefined symbols....
282 (let* ((symbol (subseq line 11))
283 (address (parse-integer line :end 8 :radix 16))
284 (kind (aref line 9)) ; filter out .o file names
285 (old-address (gethash symbol lisp::*foreign-symbols*)))
286 (unless (or (null old-address) (= address old-address)
287 (char= kind #\F))
288 (warn "~S moved from #x~8,'0X to #x~8,'0X.~%"
289 symbol old-address address))
290 (setf (gethash symbol symbol-table) address))))))
291 (setf lisp::*foreign-symbols* symbol-table)))
292 ) ;; #-(or linux bsd svr4)
293
294
295
296 ;;; pw-- This seems to work for FreeBSD. The MAGIC field is not tested
297 ;;; for correct file format so it may croak if ld fails to produce the
298 ;;; expected results. It is probably good enough for now.
299 #+(or (and FreeBSD (not ELF)) (and sparc (not svr4)))
300 (defun load-object-file (name)
301 (format t ";;; Loading object file...~%")
302 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
303 (unless fd
304 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
305 (unwind-protect
306 (alien:with-alien ((header exec))
307 (unix:unix-read fd
308 (alien:alien-sap header)
309 (alien:alien-size exec :bytes))
310 (let* ((len-of-text-and-data
311 (+ (alien:slot header 'text) (alien:slot header 'data)))
312 (memory-needed
313 (+ len-of-text-and-data (alien:slot header 'bss)))
314 (addr (allocate-space-in-foreign-segment memory-needed)))
315 (unix:unix-read fd addr len-of-text-and-data)))
316 (unix:unix-close fd))))
317
318
319 #+hppa
320 (alien:def-alien-type nil
321 (alien:struct sys_clock
322 (secs c-call:unsigned-int)
323 (nanosecs c-call:unsigned-int)))
324 #+hppa
325 (alien:def-alien-type nil
326 (alien:struct header
327 (system_id c-call:short)
328 (a_magic c-call:short)
329 (version_id c-call:unsigned-int)
330 (file_time (alien:struct sys_clock))
331 (entry_space c-call:unsigned-int)
332 (entry_subspace c-call:unsigned-int)
333 (entry_offset c-call:unsigned-int)
334 (aux_header_location c-call:unsigned-int)
335 (aux_header_size c-call:unsigned-int)
336 (som_length c-call:unsigned-int)
337 (presumed_dp c-call:unsigned-int)
338 (space_location c-call:unsigned-int)
339 (space_total c-call:unsigned-int)
340 (subspace_location c-call:unsigned-int)
341 (subspace_total c-call:unsigned-int)
342 (loader_fixup_location c-call:unsigned-int)
343 (loader_fixup_total c-call:unsigned-int)
344 (space_strings_location c-call:unsigned-int)
345 (space_strings_size c-call:unsigned-int)
346 (init_array_location c-call:unsigned-int)
347 (init_array_total c-call:unsigned-int)
348 (compiler_location c-call:unsigned-int)
349 (compiler_total c-call:unsigned-int)
350 (symbol_location c-call:unsigned-int)
351 (symbol_total c-call:unsigned-int)
352 (fixup_request_location c-call:unsigned-int)
353 (fixup_request_total c-call:unsigned-int)
354 (symbol_strings_location c-call:unsigned-int)
355 (symbol_strings_size c-call:unsigned-int)
356 (unloadable_sp_location c-call:unsigned-int)
357 (unloadable_sp_size c-call:unsigned-int)
358 (checksum c-call:unsigned-int)))
359
360 #+hppa
361 (alien:def-alien-type nil
362 (alien:struct aux_id
363 #|
364 (mandatory c-call:unsigned-int 1)
365 (copy c-call:unsigned-int 1)
366 (append c-call:unsigned-int 1)
367 (ignore c-call:unsigned-int 1)
368 (reserved c-call:unsigned-int 12)
369 (type c-call:unsigned-int 16)
370 |#
371 (dummy c-call:unsigned-int)
372 (length c-call:unsigned-int)))
373 #+hppa
374 (alien:def-alien-type nil
375 (alien:struct som_exec_auxhdr
376 (som_auxhdr (alien:struct aux_id))
377 (exec_tsize c-call:long)
378 (exec_tmem c-call:long)
379 (exec_tfile c-call:long)
380 (exec_dsize c-call:long)
381 (exec_dmem c-call:long)
382 (exec_dfile c-call:long)
383 (exec_bsize c-call:long)
384 (exec_entry c-call:long)
385 (exec_flags c-call:long)
386 (exec_bfill c-call:long)))
387
388 #+hppa
389 (alien:def-alien-routine ("bzero" unix-bzero) c-call:void
390 (s alien:system-area-pointer)
391 (n c-call:unsigned-long))
392
393 #+hppa
394 (defconstant reloc-magic #x106)
395 #+hppa
396 (defconstant cpu-pa-risc1-0 #x20b)
397 #+hppa
398 (defconstant cpu-pa-risc1-1 #x210)
399 #+hppa
400 (defconstant cpu-pa-risc-max #x2ff)
401
402 #+hppa
403 (defun load-object-file (name)
404 (format t ";;; Loading object file...~%")
405 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
406 (unless fd
407 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
408 (unwind-protect
409 (alien:with-alien ((header (alien:struct som_exec_auxhdr)))
410 (unix:unix-lseek fd (alien:alien-size (alien:struct header) :bytes)
411 unix:l_set)
412 (unix:unix-read fd
413 (alien:alien-sap header)
414 (alien:alien-size (alien:struct som_exec_auxhdr)
415 :bytes))
416 (let* ((tmem (alien:slot header 'exec_tmem))
417 (tsize (alien:slot header 'exec_tsize))
418 (dmem (alien:slot header 'exec_dmem))
419 (dsize (alien:slot header 'exec_dsize))
420 (bsize (alien:slot header 'exec_bsize))
421 (memory-needed (+ tsize dsize bsize (* 2 4096)))
422 (addr (allocate-space-in-foreign-segment memory-needed)))
423 (unix-bzero addr memory-needed) ;force valid
424 (unix:unix-lseek fd (alien:slot header 'exec_tfile) unix:l_set)
425 (unix:unix-read fd (system:int-sap tmem) tsize)
426 (unix:unix-lseek fd (alien:slot header 'exec_dfile) unix:l_set)
427 (unix:unix-read fd (system:int-sap dmem) dsize)
428 (unix-bzero (system:int-sap (+ dmem dsize)) bsize)
429 ;;(format t "tmem ~X tsize ~X dmem ~X dsize ~X bsize ~X~%"
430 ;; tmem tsize dmem dsize bsize)
431 ;;(format t "tfile ~X dfile ~X~%"
432 ;; (alien:slot header 'exec_tfile)
433 ;; (alien:slot header 'exec_dfile))
434 (alien:alien-funcall (alien:extern-alien
435 "sanctify_for_execution"
436 (alien:function c-call:void
437 alien:system-area-pointer
438 c-call:unsigned-long))
439 addr (+ (- dmem tmem) dsize bsize))
440 ))
441 (unix:unix-close fd))))
442
443 #-(or linux bsd solaris irix)
444 (progn
445 (defun parse-symbol-table (name)
446 (format t ";;; Parsing symbol table...~%")
447 (let ((symbol-table (make-hash-table :test #'equal)))
448 (with-open-file (file name)
449 (loop
450 (let ((line (read-line file nil nil)))
451 (unless line
452 (return))
453 (let* ((symbol (subseq line 11))
454 (address (parse-integer line :end 8 :radix 16))
455 #+BSD (kind (aref line 9)) ; filter out .o file names
456 (old-address (gethash symbol lisp::*foreign-symbols*)))
457 (unless (or (null old-address) (= address old-address)
458 #+BSD (char= kind #\F))
459 (warn "~S moved from #x~8,'0X to #x~8,'0X.~%"
460 symbol old-address address))
461 (setf (gethash symbol symbol-table) address)))))
462 (setf lisp::*foreign-symbols* symbol-table)))
463
464 (defun load-foreign (files &key
465 (libraries '("-lc"))
466 (base-file
467 #-hpux
468 (merge-pathnames *command-line-utility-name*
469 "path:")
470 #+hpux "library:cmucl.orig")
471 (env ext:*environment-list*)
472 (verbose *load-verbose*))
473 "Load-foreign loads a list of C object files into a running Lisp. The files
474 argument should be a single file or a list of files. The files may be
475 specified as namestrings or as pathnames. The libraries argument should be a
476 list of library files as would be specified to ld. They will be searched in
477 the order given. The default is just \"-lc\", i.e., the C library. The
478 base-file argument is used to specify a file to use as the starting place for
479 defined symbols. The default is the C start up code for Lisp. The env
480 argument is the Unix environment variable definitions for the invocation of
481 the linker. The default is the environment passed to Lisp."
482 (let ((output-file (pick-temporary-file-name))
483 (symbol-table-file (pick-temporary-file-name))
484 (error-output (make-string-output-stream))
485 (files (if (atom files) (list files) files)))
486
487 (when verbose
488 (format t ";;; Running library:load-foreign.csh...~%")
489 (force-output))
490 #+hpux
491 (dolist (f files)
492 (with-open-file (stream f :element-type '(unsigned-byte 16))
493 (unless (let ((sysid (read-byte stream)))
494 (or (eql sysid cpu-pa-risc1-0)
495 (and (>= sysid cpu-pa-risc1-1)
496 (<= sysid cpu-pa-risc-max))))
497 (error "Object file is wrong format, so can't load-foreign:~
498 ~% ~S"
499 f))
500 (unless (eql (read-byte stream) reloc-magic)
501 (error "Object file is not relocatable, so can't load-foreign:~
502 ~% ~S"
503 f))))
504
505 (let ((proc (ext:run-program
506 "library:load-foreign.csh"
507 (list* (or *previous-linked-object-file*
508 (namestring (truename base-file)))
509 (format nil "~X"
510 *foreign-segment-free-pointer*)
511 output-file
512 symbol-table-file
513 (append (mapcar
514 #'(lambda (name)
515 (or (unix-namestring name)
516 (error 'simple-file-error
517 :pathname name
518 :format-control
519 "File does not exist: ~A."
520 :format-arguments
521 (list name))))
522
523 files)
524 libraries))
525 :env env
526 :input nil
527 :output error-output
528 :error :output)))
529 (unless proc
530 (error "Could not run library:load-foreign.csh"))
531 (unless (zerop (ext:process-exit-code proc))
532 (system:serve-all-events 0)
533 (error "library:load-foreign.csh failed:~%~A"
534 (get-output-stream-string error-output)))
535 (load-object-file output-file)
536 (parse-symbol-table symbol-table-file)
537 (unix:unix-unlink symbol-table-file)
538 (let ((old-file *previous-linked-object-file*))
539 (setf *previous-linked-object-file* output-file)
540 (when old-file
541 (unix:unix-unlink old-file)))))
542 (when verbose
543 (format t ";;; Done.~%")
544 (force-output)))
545
546
547 (export '(alternate-get-global-address))
548
549 (defun alternate-get-global-address (symbol)
550 (declare (type simple-string symbol)
551 (ignore symbol))
552 0)
553 ) ;; #-(or linux bsd solaris irix)
554
555
556 ;; Modern dlopen()-based loading of shared libraries
557 #+(or linux bsd solaris irix)
558 (progn
559
560 (defconstant rtld-lazy 1
561 "Lazy function call binding")
562 (defconstant rtld-now 2
563 "Immediate function call binding")
564 #+(and linux glibc2)
565 (defconstant rtld-binding-mask #x3
566 "Mask of binding time value")
567
568 (defconstant rtld-global #-irix #x100 #+irix 4
569 "If set the symbols of the loaded object and its dependencies are
570 made visible as if the object were linked directly into the program")
571
572 (defvar *global-table* nil)
573 ;;; Dynamically loaded stuff isn't there upon restoring from a
574 ;;; save--this is primarily for irix, which resolves tzname at
575 ;;; runtime, resulting in *global-table* being set in the saved core
576 ;;; image, resulting in havoc upon restart.
577 #-linkage-table
578 (pushnew #'(lambda () (setq *global-table* nil))
579 ext:*after-save-initializations*)
580
581 (defvar *dso-linker*
582 #+solaris "/usr/ccs/bin/ld"
583 #-solaris "/usr/bin/ld")
584
585 (alien:def-alien-routine dlopen system-area-pointer
586 (file c-call:c-string) (mode c-call:int))
587 (alien:def-alien-routine dlsym system-area-pointer
588 (lib system-area-pointer)
589 (name c-call:c-string))
590 (alien:def-alien-routine dlclose void (lib system-area-pointer))
591 (alien:def-alien-routine dlerror c-call:c-string)
592
593 ;;; Ensure we've opened our own binary so can resolve global variables
594 ;;; in the lisp image that come from libraries. This used to happen
595 ;;; only in alternate-get-global-address, and only if no libraries
596 ;;; were dlopened already, but that didn't work if something was
597 ;;; dlopened before any problem global vars were used. So now we do
598 ;;; this in any function that can add to the global-table, as well as
599 ;;; in alternate-get-global-address.
600 (defun ensure-lisp-table-opened ()
601 (unless *global-table*
602 ;; Prevent recursive call if dlopen isn't defined
603 (setf *global-table* (acons (int-sap 0) nil nil))
604 (setf *global-table* (acons (dlopen nil rtld-lazy) nil nil))
605 (when (zerop (system:sap-int (caar *global-table*)))
606 (error "Can't open global symbol table: ~S" (dlerror)))))
607
608 (defun load-object-file (file)
609 (ensure-lisp-table-opened)
610 ; rtld global: so it can find all the symbols previously loaded
611 ; rtld now: that way dlopen will fail if not all symbols are defined.
612 (let* ((filename (namestring file ))
613 (sap (dlopen filename (logior rtld-now rtld-global))))
614 (cond ((zerop (sap-int sap))
615 (let ((err-string (dlerror))
616 (sap (dlopen filename (logior rtld-lazy rtld-global))))
617 ;; For some reason dlerror always seems to return NIL,
618 ;; which isn't very informative.
619 (when (zerop (sap-int sap))
620 (error "Can't open object ~S: ~S" file err-string))
621 (dlclose sap)
622 (error "LOAD-OBJECT-FILE: Unresolved symbols in file ~S: ~S"
623 file err-string)))
624 ((null (assoc sap *global-table* :test #'sap=))
625 (setf *global-table* (acons sap file *global-table*)))
626 (t nil))))
627
628 ;;; Clear close all dlopened libraries and clear out the entries in
629 ;;; *global-table*, prior to doing a save-lisp.
630
631 (defun close-global-table ()
632 (loop for lib-entry in *global-table*
633 for (sap) = lib-entry
634 do (progn
635 (dlclose sap)
636 ;; Probably not necessary, but neater than leaving around
637 ;; stale handles in the saved image.
638 (setf (car lib-entry) (int-sap 0)))))
639
640 ;;; Open all the libraries in *GLOBAL-TABLE*. We open them in the same
641 ;;; order as the first time they were loaded, so that any dependencies
642 ;;; on load order are respected.
643 (defun reinitialize-global-table ()
644 (loop for lib-entry in (reverse *global-table*)
645 for (sap . lib-path) = lib-entry
646 when lib-path
647 do (let ((new-sap (dlopen (namestring lib-path)
648 (logior rtld-now rtld-global))))
649 (when (zerop (sap-int new-sap))
650 ;; We're going down
651 (error "Couldn't open library ~S: ~S" lib-path (dlerror)))
652 (setf (car lib-entry) new-sap)))
653 (alien:alien-funcall (alien:extern-alien "os_resolve_data_linkage"
654 (alien:function c-call:void))))
655
656 (defun alternate-get-global-address (symbol)
657 (ensure-lisp-table-opened)
658 ;; find the symbol in any of the loaded objects,
659 ;; search in reverse order of loading, later loadings
660 ;; take precedence
661 (let ((result 0))
662 (do ((table *global-table* (cdr table)))
663 ((or (null (car table)) (not (zerop result))))
664 (setq result (sap-int (dlsym (caar table) symbol))))
665 (values result)))
666
667 (defun load-foreign (files &key
668 (libraries '("-lc"))
669 (base-file nil)
670 (env ext:*environment-list*)
671 (verbose *load-verbose*))
672 "Load C object files into the running Lisp. The FILES argument
673 should be a single file or a list of files. The files may be specified
674 as namestrings or as pathnames. The LIBRARIES argument should be a
675 list of library files as would be specified to ld. They will be
676 searched in the order given. The default is just \"-lc\", i.e., the C
677 library. The BASE-FILE argument is used to specify a file to use as
678 the starting place for defined symbols. The default is the C start up
679 code for Lisp. The ENV argument is the Unix environment variable
680 definitions for the invocation of the linker. The default is the
681 environment passed to Lisp."
682 ;; Note: dlopen remembers the name of an object, when dlopenin
683 ;; the same name twice, the old objects is reused.
684 (declare (ignore base-file))
685 ;; if passed a single shared object that can be loaded directly via
686 ;; dlopen(), do that instead of using the linker
687 (cond ((and (atom files)
688 (probe-file files)
689 (file-shared-library-p files))
690 (when verbose
691 (format t ";;; Opening shared library ~A ...~%" files))
692 (load-object-file files)
693 (when verbose
694 (format t ";;; Done.~%")))
695 (t
696 (let ((output-file (pick-temporary-file-name
697 (concatenate 'string "/tmp/~D~C" (string (gensym)))))
698 (error-output (make-string-output-stream)))
699
700 (when verbose
701 (format t ";;; Running ~A...~%" *dso-linker*)
702 (force-output))
703
704 (let ((proc (ext:run-program
705 *dso-linker*
706 (list*
707 #+(or solaris linux FreeBSD4) "-G"
708 #+(or OpenBSD NetBSD irix) "-shared"
709 "-o"
710 output-file
711 ;; Cause all specified libs to be loaded in full
712 #+(or OpenBSD linux FreeBSD4 NetBSD) "--whole-archive"
713 #+solaris "-z" #+solaris "allextract"
714 (append (mapcar
715 #'(lambda (name)
716 (or (unix-namestring name)
717 (error 'simple-file-error
718 :pathname name
719 :format-control
720 "File does not exist: ~A."
721 :format-arguments
722 (list name))))
723 (if (atom files)
724 (list files)
725 files))
726 ;; Return to default ld behaviour for libs
727 (list
728 #+(or OpenBSD linux FreeBSD4 NetBSD)
729 "--no-whole-archive"
730 #+solaris "-z" #+solaris "defaultextract")
731 libraries))
732 ;; on Linux/AMD64, we need to tell the platform linker to use the 32-bit
733 ;; linking mode instead of the default 64-bit mode. This can be done either
734 ;; via the LDEMULATION environment variable, or via the "-m" command-line
735 ;; option. Here we assume that LDEMULATION will be ignored by the platform
736 ;; linker on Linux/i386 platforms.
737 :env `(#+(and x86 linux) (:ldemulation . "elf_i386") ,@env)
738 :input nil
739 :output error-output
740 :error :output)))
741 (unless proc
742 (error "Could not run ~A" *dso-linker*))
743 (unless (zerop (ext:process-exit-code proc))
744 (system:serve-all-events 0)
745 (error "~A failed:~%~A" *dso-linker*
746 (get-output-stream-string error-output)))
747 (load-object-file output-file)
748 (unix:unix-unlink output-file)))
749 (when verbose
750 (format t ";;; Done.~%")
751 (force-output)))))
752
753 ) ;; #+(or linux bsd solaris irix)

  ViewVC Help
Powered by ViewVC 1.1.5