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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.54.12.1 - (show annotations)
Sat Nov 1 22:40:35 2008 UTC (5 years, 5 months ago) by rtoy
Branch: unicode-utf16-branch
CVS Tags: unicode-utf16-sync-2008-12, unicode-utf16-sync-label-2009-03-16, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, unicode-utf16-sync-2008-11
Changes since 1.54: +2 -2 lines
Sync to snapshot 2008-11.
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.54.12.1 2008/11/01 22:40:35 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 ;;; Support for loading multi-arch ("fat") shared libraries.
245 (alien:def-alien-type fat-header
246 (alien:struct nil
247 (magic (alien:unsigned 32))
248 (nfat-arch (alien:unsigned 32))))
249
250 (alien:def-alien-type fat-arch
251 (alien:struct nil
252 (cputype (alien:signed 32))
253 (cpusubtype (alien:signed 32))
254 (offset (alien:unsigned 32))
255 (size (alien:unsigned 32))
256 (align (alien:unsigned 32))))
257
258 (defconstant fat-header-magic #xcafebabe)
259
260 (defun mach-o-p (h)
261 "Make sure the header starts with the mach-o magic value."
262 (eql (alien:slot h 'magic) mh-magic))
263
264 ;;; Read an unsigned 32-bit big-endian number from STREAM.
265 (defun read-u32-be (stream)
266 (let ((n 0))
267 (setf (ldb (byte 8 24) n) (read-byte stream))
268 (setf (ldb (byte 8 16) n) (read-byte stream))
269 (setf (ldb (byte 8 8) n) (read-byte stream))
270 (setf (ldb (byte 8 0) n) (read-byte stream))
271 n))
272
273 ;;; Read the 32-bit magic number from STREAM then rewind it.
274 (defun read-object-file-magic (stream)
275 (let ((pos (file-position stream)))
276 (prog1
277 (read-u32-be stream)
278 (file-position stream pos))))
279
280 ;;; XXX For a Darwin/x86 port, these functions will need to swap the
281 ;;; byte order of the structure members. Apple's documentation states
282 ;;; that all the fields of FAT-HEADER and FAT-ARCH are big-endian.
283 (defun read-mach-header (stream sap)
284 (unix:unix-read (lisp::fd-stream-fd stream) sap
285 (alien:alien-size machheader :bytes)))
286
287 (defun read-fat-header (stream sap)
288 (unix:unix-read (lisp::fd-stream-fd stream) sap
289 (alien:alien-size fat-header :bytes)))
290
291 (defun read-fat-arch (stream sap)
292 (unix:unix-read (lisp::fd-stream-fd stream) sap
293 (alien:alien-size fat-arch :bytes)))
294
295 ;;; Return a list of offsets in STREAM which contain Mach-O headers.
296 ;;; For single-architecture binaries, this will return (0), emulating
297 ;;; the previous behavior of loading the header from the start of the
298 ;;; file. For fat binaries, there will be one offset in the result
299 ;;; list for each architecture present in the file.
300 (defun read-mach-header-offsets (stream)
301 (let ((magic (read-object-file-magic stream)))
302 (cond ((eql magic mh-magic)
303 (list 0))
304 ((eql magic fat-header-magic)
305 (alien:with-alien ((fat-header fat-header)
306 (fat-arch fat-arch))
307 (read-fat-header stream (alien:alien-sap fat-header))
308 (loop
309 for i from 0 below (alien:slot fat-header 'nfat-arch)
310 do (read-fat-arch stream (alien:alien-sap fat-arch))
311 collect (alien:slot fat-arch 'offset))))
312 (t nil))))
313
314 ;;; Return true if the Mach-O HEADER represents a shared library.
315 (defun shared-mach-header-p (header)
316 (and (eql (alien:slot header 'magic) mh-magic)
317 (or (eql (alien:slot header 'filetype) mh-dylib)
318 (eql (alien:slot header 'filetype) mh-bundle))))
319
320 (defun file-shared-library-p (pathname)
321 (with-open-file (obj pathname
322 :direction :input
323 :element-type '(unsigned-byte 8))
324 (let ((offsets (read-mach-header-offsets obj)))
325 (when offsets
326 (alien:with-alien ((header machheader))
327 (loop
328 for offset in offsets
329 do (file-position obj offset)
330 (read-mach-header obj (alien:alien-sap header))
331 thereis (shared-mach-header-p header)))))))
332 ) ; #+darwin
333
334
335
336 ;; "old-style" loading of foreign code. This involves calling a
337 ;; platform-specific script that is installed as
338 ;; library:load-foreign.csh to convert the object files into a form
339 ;; that is suitable for being stuffed into memory at runtime.
340 #-(or linux bsd svr4)
341 (progn
342 (defun load-object-file (name)
343 ;; NAME designates a tempory file created by ld via "load-foreign.csh".
344 ;; Its contents are in a form suitable for stuffing into memory for
345 ;; execution. This function extracts the location and size of the
346 ;; relevant bits and reads them into memory.
347
348 #|| library:load-foreign.csh
349 #!/bin/csh -fx
350 ld -N -R $argv[1] -Ttext $argv[2] -o $argv[3] $argv[5-]
351 if ($status != 0) exit 1
352
353 nm -gp $argv[3] > $argv[4]
354 if ($status != 0) exit 2
355 exit 0
356 ||#
357
358 (format t ";;; Loading object file...~%")
359 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
360 (unless fd
361 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
362 (unwind-protect
363 (alien:with-alien ((header eheader))
364 (unix:unix-read fd
365 (alien:alien-sap header)
366 (alien:alien-size eheader :bytes))
367 (unless (elf-p (alien:slot header 'elf-ident))
368 (error (format nil "~A is not an ELF file." name)))
369
370 (let ((osabi (elf-osabi (alien:slot header 'elf-ident)))
371 (expected-osabi #+NetBSD elfosabi-netbsd
372 #+FreeBSD elfosabi-freebsd))
373 (unless (= osabi expected-osabi)
374 (error "~A is not a ~A executable, it's a ~A executable."
375 name
376 (elf-osabi-name expected-osabi)
377 (elf-osabi-name osabi))))
378
379 (unless (elf-executable-p (alien:slot header 'elf-type))
380 (error (format nil "~A is not executable." name)))
381
382 (alien:with-alien ((program-header pheader))
383 (unix:unix-read fd
384 (alien:alien-sap program-header)
385 (alien:alien-size pheader :bytes))
386 (let* ((addr (system::allocate-space-in-foreign-segment
387 (alien:slot program-header 'p-memory-size))))
388 (unix:unix-lseek
389 fd (alien:slot program-header 'p-offset) unix:l_set)
390 (unix:unix-read
391 fd addr (alien:slot program-header 'p-file-size)))))
392 (unix:unix-close fd))))
393
394 (defun parse-symbol-table (name)
395 "Parse symbol table file created by load-foreign script. Modified
396 to skip undefined symbols which don't have an address."
397 (format t ";;; Parsing symbol table...~%")
398 (let ((symbol-table (make-hash-table :test #'equal)))
399 (with-open-file (file name)
400 (loop
401 (let ((line (read-line file nil nil)))
402 (unless line
403 (return))
404 (unless (eql (aref line 0) #\space) ; Skip undefined symbols....
405 (let* ((symbol (subseq line 11))
406 (address (parse-integer line :end 8 :radix 16))
407 (kind (aref line 9)) ; filter out .o file names
408 (old-address (gethash symbol lisp::*foreign-symbols*)))
409 (unless (or (null old-address) (= address old-address)
410 (char= kind #\F))
411 (warn "~S moved from #x~8,'0X to #x~8,'0X.~%"
412 symbol old-address address))
413 (setf (gethash symbol symbol-table) address))))))
414 (setf lisp::*foreign-symbols* symbol-table)))
415 ) ;; #-(or linux bsd svr4)
416
417
418
419 ;;; pw-- This seems to work for FreeBSD. The MAGIC field is not tested
420 ;;; for correct file format so it may croak if ld fails to produce the
421 ;;; expected results. It is probably good enough for now.
422 #+(or (and FreeBSD (not ELF)) (and sparc (not svr4)))
423 (defun load-object-file (name)
424 (format t ";;; Loading object file...~%")
425 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
426 (unless fd
427 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
428 (unwind-protect
429 (alien:with-alien ((header exec))
430 (unix:unix-read fd
431 (alien:alien-sap header)
432 (alien:alien-size exec :bytes))
433 (let* ((len-of-text-and-data
434 (+ (alien:slot header 'text) (alien:slot header 'data)))
435 (memory-needed
436 (+ len-of-text-and-data (alien:slot header 'bss)))
437 (addr (allocate-space-in-foreign-segment memory-needed)))
438 (unix:unix-read fd addr len-of-text-and-data)))
439 (unix:unix-close fd))))
440
441
442 #+hppa
443 (alien:def-alien-type nil
444 (alien:struct sys_clock
445 (secs c-call:unsigned-int)
446 (nanosecs c-call:unsigned-int)))
447 #+hppa
448 (alien:def-alien-type nil
449 (alien:struct header
450 (system_id c-call:short)
451 (a_magic c-call:short)
452 (version_id c-call:unsigned-int)
453 (file_time (alien:struct sys_clock))
454 (entry_space c-call:unsigned-int)
455 (entry_subspace c-call:unsigned-int)
456 (entry_offset c-call:unsigned-int)
457 (aux_header_location c-call:unsigned-int)
458 (aux_header_size c-call:unsigned-int)
459 (som_length c-call:unsigned-int)
460 (presumed_dp c-call:unsigned-int)
461 (space_location c-call:unsigned-int)
462 (space_total c-call:unsigned-int)
463 (subspace_location c-call:unsigned-int)
464 (subspace_total c-call:unsigned-int)
465 (loader_fixup_location c-call:unsigned-int)
466 (loader_fixup_total c-call:unsigned-int)
467 (space_strings_location c-call:unsigned-int)
468 (space_strings_size c-call:unsigned-int)
469 (init_array_location c-call:unsigned-int)
470 (init_array_total c-call:unsigned-int)
471 (compiler_location c-call:unsigned-int)
472 (compiler_total c-call:unsigned-int)
473 (symbol_location c-call:unsigned-int)
474 (symbol_total c-call:unsigned-int)
475 (fixup_request_location c-call:unsigned-int)
476 (fixup_request_total c-call:unsigned-int)
477 (symbol_strings_location c-call:unsigned-int)
478 (symbol_strings_size c-call:unsigned-int)
479 (unloadable_sp_location c-call:unsigned-int)
480 (unloadable_sp_size c-call:unsigned-int)
481 (checksum c-call:unsigned-int)))
482
483 #+hppa
484 (alien:def-alien-type nil
485 (alien:struct aux_id
486 #|
487 (mandatory c-call:unsigned-int 1)
488 (copy c-call:unsigned-int 1)
489 (append c-call:unsigned-int 1)
490 (ignore c-call:unsigned-int 1)
491 (reserved c-call:unsigned-int 12)
492 (type c-call:unsigned-int 16)
493 |#
494 (dummy c-call:unsigned-int)
495 (length c-call:unsigned-int)))
496 #+hppa
497 (alien:def-alien-type nil
498 (alien:struct som_exec_auxhdr
499 (som_auxhdr (alien:struct aux_id))
500 (exec_tsize c-call:long)
501 (exec_tmem c-call:long)
502 (exec_tfile c-call:long)
503 (exec_dsize c-call:long)
504 (exec_dmem c-call:long)
505 (exec_dfile c-call:long)
506 (exec_bsize c-call:long)
507 (exec_entry c-call:long)
508 (exec_flags c-call:long)
509 (exec_bfill c-call:long)))
510
511 #+hppa
512 (alien:def-alien-routine ("bzero" unix-bzero) c-call:void
513 (s alien:system-area-pointer)
514 (n c-call:unsigned-long))
515
516 #+hppa
517 (defconstant reloc-magic #x106)
518 #+hppa
519 (defconstant cpu-pa-risc1-0 #x20b)
520 #+hppa
521 (defconstant cpu-pa-risc1-1 #x210)
522 #+hppa
523 (defconstant cpu-pa-risc-max #x2ff)
524
525 #+hppa
526 (defun load-object-file (name)
527 (format t ";;; Loading object file...~%")
528 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
529 (unless fd
530 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
531 (unwind-protect
532 (alien:with-alien ((header (alien:struct som_exec_auxhdr)))
533 (unix:unix-lseek fd (alien:alien-size (alien:struct header) :bytes)
534 unix:l_set)
535 (unix:unix-read fd
536 (alien:alien-sap header)
537 (alien:alien-size (alien:struct som_exec_auxhdr)
538 :bytes))
539 (let* ((tmem (alien:slot header 'exec_tmem))
540 (tsize (alien:slot header 'exec_tsize))
541 (dmem (alien:slot header 'exec_dmem))
542 (dsize (alien:slot header 'exec_dsize))
543 (bsize (alien:slot header 'exec_bsize))
544 (memory-needed (+ tsize dsize bsize (* 2 4096)))
545 (addr (allocate-space-in-foreign-segment memory-needed)))
546 (unix-bzero addr memory-needed) ;force valid
547 (unix:unix-lseek fd (alien:slot header 'exec_tfile) unix:l_set)
548 (unix:unix-read fd (system:int-sap tmem) tsize)
549 (unix:unix-lseek fd (alien:slot header 'exec_dfile) unix:l_set)
550 (unix:unix-read fd (system:int-sap dmem) dsize)
551 (unix-bzero (system:int-sap (+ dmem dsize)) bsize)
552 ;;(format t "tmem ~X tsize ~X dmem ~X dsize ~X bsize ~X~%"
553 ;; tmem tsize dmem dsize bsize)
554 ;;(format t "tfile ~X dfile ~X~%"
555 ;; (alien:slot header 'exec_tfile)
556 ;; (alien:slot header 'exec_dfile))
557 (alien:alien-funcall (alien:extern-alien
558 "sanctify_for_execution"
559 (alien:function c-call:void
560 alien:system-area-pointer
561 c-call:unsigned-long))
562 addr (+ (- dmem tmem) dsize bsize))
563 ))
564 (unix:unix-close fd))))
565
566 #-(or linux bsd solaris irix)
567 (progn
568 (defun parse-symbol-table (name)
569 (format t ";;; Parsing symbol table...~%")
570 (let ((symbol-table (make-hash-table :test #'equal)))
571 (with-open-file (file name)
572 (loop
573 (let ((line (read-line file nil nil)))
574 (unless line
575 (return))
576 (let* ((symbol (subseq line 11))
577 (address (parse-integer line :end 8 :radix 16))
578 #+BSD (kind (aref line 9)) ; filter out .o file names
579 (old-address (gethash symbol lisp::*foreign-symbols*)))
580 (unless (or (null old-address) (= address old-address)
581 #+BSD (char= kind #\F))
582 (warn "~S moved from #x~8,'0X to #x~8,'0X.~%"
583 symbol old-address address))
584 (setf (gethash symbol symbol-table) address)))))
585 (setf lisp::*foreign-symbols* symbol-table)))
586
587 (defun load-foreign (files &key
588 (libraries '("-lc"))
589 (base-file
590 #-hpux
591 (merge-pathnames *command-line-utility-name*
592 "path:")
593 #+hpux "library:cmucl.orig")
594 (env ext:*environment-list*)
595 (verbose *load-verbose*))
596 "Load-foreign loads a list of C object files into a running Lisp. The files
597 argument should be a single file or a list of files. The files may be
598 specified as namestrings or as pathnames. The libraries argument should be a
599 list of library files as would be specified to ld. They will be searched in
600 the order given. The default is just \"-lc\", i.e., the C library. The
601 base-file argument is used to specify a file to use as the starting place for
602 defined symbols. The default is the C start up code for Lisp. The env
603 argument is the Unix environment variable definitions for the invocation of
604 the linker. The default is the environment passed to Lisp."
605 (let ((output-file (pick-temporary-file-name))
606 (symbol-table-file (pick-temporary-file-name))
607 (error-output (make-string-output-stream))
608 (files (if (atom files) (list files) files)))
609
610 (when verbose
611 (format t ";;; Running library:load-foreign.csh...~%")
612 (force-output))
613 #+hpux
614 (dolist (f files)
615 (with-open-file (stream f :element-type '(unsigned-byte 16))
616 (unless (let ((sysid (read-byte stream)))
617 (or (eql sysid cpu-pa-risc1-0)
618 (and (>= sysid cpu-pa-risc1-1)
619 (<= sysid cpu-pa-risc-max))))
620 (error "Object file is wrong format, so can't load-foreign:~
621 ~% ~S"
622 f))
623 (unless (eql (read-byte stream) reloc-magic)
624 (error "Object file is not relocatable, so can't load-foreign:~
625 ~% ~S"
626 f))))
627
628 (let ((proc (ext:run-program
629 "library:load-foreign.csh"
630 (list* (or *previous-linked-object-file*
631 (namestring (truename base-file)))
632 (format nil "~X"
633 *foreign-segment-free-pointer*)
634 output-file
635 symbol-table-file
636 (append (mapcar
637 #'(lambda (name)
638 (or (unix-namestring name)
639 (error 'simple-file-error
640 :pathname name
641 :format-control
642 "File does not exist: ~A."
643 :format-arguments
644 (list name))))
645
646 files)
647 libraries))
648 :env env
649 :input nil
650 :output error-output
651 :error :output)))
652 (unless proc
653 (error "Could not run library:load-foreign.csh"))
654 (unless (zerop (ext:process-exit-code proc))
655 (system:serve-all-events 0)
656 (error "library:load-foreign.csh failed:~%~A"
657 (get-output-stream-string error-output)))
658 (load-object-file output-file)
659 (parse-symbol-table symbol-table-file)
660 (unix:unix-unlink symbol-table-file)
661 (let ((old-file *previous-linked-object-file*))
662 (setf *previous-linked-object-file* output-file)
663 (when old-file
664 (unix:unix-unlink old-file)))))
665 (when verbose
666 (format t ";;; Done.~%")
667 (force-output)))
668
669
670 (export '(alternate-get-global-address))
671
672 (defun alternate-get-global-address (symbol)
673 (declare (type simple-string symbol)
674 (ignore symbol))
675 0)
676 ) ;; #-(or linux bsd solaris irix)
677
678
679 ;; Modern dlopen()-based loading of shared libraries
680 #+(or linux bsd solaris irix)
681 (progn
682
683 (defconstant rtld-lazy 1
684 "Lazy function call binding")
685 (defconstant rtld-now 2
686 "Immediate function call binding")
687 #+(and linux glibc2)
688 (defconstant rtld-binding-mask #x3
689 "Mask of binding time value")
690
691 (defconstant rtld-global #-irix #x100 #+irix 4
692 "If set the symbols of the loaded object and its dependencies are
693 made visible as if the object were linked directly into the program")
694
695 (defvar *global-table* nil)
696 ;;; Dynamically loaded stuff isn't there upon restoring from a
697 ;;; save--this is primarily for irix, which resolves tzname at
698 ;;; runtime, resulting in *global-table* being set in the saved core
699 ;;; image, resulting in havoc upon restart.
700 #-linkage-table
701 (pushnew #'(lambda () (setq *global-table* nil))
702 ext:*after-save-initializations*)
703
704 (defvar *dso-linker*
705 #+solaris "/usr/ccs/bin/ld"
706 #-solaris "/usr/bin/ld")
707
708 (alien:def-alien-routine dlopen system-area-pointer
709 (file c-call:c-string) (mode c-call:int))
710 (alien:def-alien-routine dlsym system-area-pointer
711 (lib system-area-pointer)
712 (name c-call:c-string))
713 (alien:def-alien-routine dlclose void (lib system-area-pointer))
714 (alien:def-alien-routine dlerror c-call:c-string)
715
716 ;;; Ensure we've opened our own binary so can resolve global variables
717 ;;; in the lisp image that come from libraries. This used to happen
718 ;;; only in alternate-get-global-address, and only if no libraries
719 ;;; were dlopened already, but that didn't work if something was
720 ;;; dlopened before any problem global vars were used. So now we do
721 ;;; this in any function that can add to the global-table, as well as
722 ;;; in alternate-get-global-address.
723 (defun ensure-lisp-table-opened ()
724 (unless *global-table*
725 ;; Prevent recursive call if dlopen isn't defined
726 (setf *global-table* (acons (int-sap 0) nil nil))
727 (setf *global-table* (acons (dlopen nil rtld-lazy) nil nil))
728 (when (zerop (system:sap-int (caar *global-table*)))
729 (error "Can't open global symbol table: ~S" (dlerror)))))
730
731 (defun convert-object-file-path (path)
732 ;; Convert path to something that dlopen might like, which means
733 ;; translating logical pathnames and converting search-lists to the
734 ;; first path that exists.
735 (cond ((lisp::logical-pathname-p (pathname path))
736 (translate-logical-pathname path))
737 ((ignore-errors (ext:search-list-defined-p (pathname path)))
738 (ext:enumerate-search-list (s (pathname path)
739 path)
740 (when (probe-file s)
741 (return s))))
742 (t
743 path)))
744
745 (defun load-object-file (file &optional (recordp t))
746 (ensure-lisp-table-opened)
747 ; rtld global: so it can find all the symbols previously loaded
748 ; rtld now: that way dlopen will fail if not all symbols are defined.
749 (let* ((filename (namestring (convert-object-file-path file)))
750 (sap (dlopen filename (logior rtld-now rtld-global))))
751 (cond ((zerop (sap-int sap))
752 (let ((err-string (dlerror))
753 (sap (dlopen filename (logior rtld-lazy rtld-global))))
754 ;; For some reason dlerror always seems to return NIL,
755 ;; which isn't very informative.
756 (when (zerop (sap-int sap))
757 (return-from load-object-file
758 (values nil (format nil "Can't open object ~S: ~S" file err-string))))
759 (dlclose sap)
760 (return-from load-object-file
761 (values nil
762 (format nil "LOAD-OBJECT-FILE: Unresolved symbols in file ~S: ~S"
763 file err-string)))))
764 ((and recordp (null (assoc sap *global-table* :test #'sap=)))
765 (setf *global-table* (acons sap file *global-table*)))
766 (t nil))))
767
768 ;;; Clear close all dlopened libraries and clear out the entries in
769 ;;; *global-table*, prior to doing a save-lisp.
770
771 (defun close-global-table ()
772 (loop for lib-entry in *global-table*
773 for (sap) = lib-entry
774 do (progn
775 (dlclose sap)
776 ;; Probably not necessary, but neater than leaving around
777 ;; stale handles in the saved image.
778 (setf (car lib-entry) (int-sap 0)))))
779
780 ;;; Open all the libraries in *GLOBAL-TABLE*. We open them in the same
781 ;;; order as the first time they were loaded, so that any dependencies
782 ;;; on load order are respected.
783 (defun reinitialize-global-table ()
784 (loop for lib-entry in (reverse *global-table*)
785 for (sap . lib-path) = lib-entry
786 when lib-path
787 do
788 (loop
789 (restart-case
790 (let ((new-sap (dlopen (namestring (convert-object-file-path lib-path))
791 (logior rtld-now rtld-global))))
792 (cond ((zerop (sap-int new-sap))
793 ;; We're going down
794 (error "Couldn't open library ~S: ~S" lib-path (dlerror)))
795 (t
796 (format t "Reloaded library ~S~%" lib-path)
797 (force-output)))
798
799 (setf (car lib-entry) new-sap)
800 (return))
801 (continue ()
802 :report "Ignore library and continue"
803 (return))
804 (try-again ()
805 :report "Try reloading again"
806 )
807 (new-library ()
808 :report "Choose new library path"
809 (format *query-io* "Enter new library path: ")
810 (setf lib-path (read))))))
811 (alien:alien-funcall (alien:extern-alien "os_resolve_data_linkage"
812 (alien:function c-call:void))))
813
814 (defun alternate-get-global-address (symbol)
815 (ensure-lisp-table-opened)
816 ;; find the symbol in any of the loaded objects,
817 ;; search in reverse order of loading, later loadings
818 ;; take precedence
819 (let ((result 0))
820 (do ((table *global-table* (cdr table)))
821 ((or (null (car table)) (not (zerop result))))
822 (setq result (sap-int (dlsym (caar table) symbol))))
823 (values result)))
824
825 (defun load-foreign (files &key
826 (libraries '("-lc"))
827 (base-file nil)
828 (env ext:*environment-list*)
829 (verbose *load-verbose*))
830 "Load C object files into the running Lisp. The FILES argument
831 should be a single file or a list of files. The files may be specified
832 as namestrings or as pathnames. The LIBRARIES argument should be a
833 list of library files as would be specified to ld. They will be
834 searched in the order given. The default is just \"-lc\", i.e., the C
835 library. The BASE-FILE argument is used to specify a file to use as
836 the starting place for defined symbols. The default is the C start up
837 code for Lisp. The ENV argument is the Unix environment variable
838 definitions for the invocation of the linker. The default is the
839 environment passed to Lisp."
840 ;; Note: dlopen remembers the name of an object, when dlopenin
841 ;; the same name twice, the old objects is reused.
842 (declare (ignore base-file))
843 ;; if passed a single shared object that can be loaded directly via
844 ;; dlopen(), do that instead of using the linker
845 (when (atom files)
846 (when verbose
847 (format t ";;; Opening as shared library ~A ...~%" files))
848 (multiple-value-bind (ok error-string)
849 (load-object-file files)
850 (cond (ok
851 (when verbose
852 (format t ";;; Done.~%")
853 (force-output))
854 (return-from load-foreign))
855 (error-string
856 (format t "~A~%" error-string)
857 (force-output))))
858
859 ;; If we get here, we couldn't open the file as a shared library.
860 ;; Try again assuming it's an object file.
861 (when verbose
862 (format t ";;; Trying as object file ~A...~%" files)))
863
864
865 (let ((output-file (pick-temporary-file-name
866 (concatenate 'string "/tmp/~D~C" (string (gensym)))))
867 (error-output (make-string-output-stream)))
868
869 (when verbose
870 (format t ";;; Running ~A...~%" *dso-linker*)
871 (force-output))
872
873 (let ((proc (ext:run-program
874 *dso-linker*
875 (list*
876 #+(or solaris linux FreeBSD4) "-G"
877 #+(or OpenBSD NetBSD irix) "-shared"
878 #+darwin "-dylib"
879 "-o"
880 output-file
881 ;; Cause all specified libs to be loaded in full
882 #+(or OpenBSD linux FreeBSD4 NetBSD) "--whole-archive"
883 #+solaris "-z" #+solaris "allextract"
884 #+darwin "-all_load"
885 (append (mapcar
886 #'(lambda (name)
887 (or (unix-namestring name)
888 (error 'simple-file-error
889 :pathname name
890 :format-control
891 "File does not exist: ~A."
892 :format-arguments
893 (list name))))
894 (if (atom files)
895 (list files)
896 files))
897 ;; Return to default ld behaviour for libs
898 (list
899 #+(or OpenBSD linux FreeBSD4 NetBSD)
900 "--no-whole-archive"
901 #+solaris "-z" #+solaris "defaultextract")
902 libraries))
903 ;; on Linux/AMD64, we need to tell the platform linker to use the 32-bit
904 ;; linking mode instead of the default 64-bit mode. This can be done either
905 ;; via the LDEMULATION environment variable, or via the "-m" command-line
906 ;; option. Here we assume that LDEMULATION will be ignored by the platform
907 ;; linker on Linux/i386 platforms.
908 :env `(#+(and x86 linux) (:ldemulation . "elf_i386") ,@env)
909 :input nil
910 :output error-output
911 :error :output)))
912 (unless proc
913 (error "Could not run ~A" *dso-linker*))
914 (unless (zerop (ext:process-exit-code proc))
915 (system:serve-all-events 0)
916 (error "~A failed:~%~A" *dso-linker*
917 (get-output-stream-string error-output)))
918 (load-object-file output-file nil)
919 (unix:unix-unlink output-file))
920 (when verbose
921 (format t ";;; Done.~%")
922 (force-output))))
923
924 #+linkage-table
925 (pushnew #'reinitialize-global-table ext:*after-save-initializations*)
926 ) ;; #+(or linux bsd solaris irix)

  ViewVC Help
Powered by ViewVC 1.1.5