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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5