/[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 - (hide 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 wlott 1.3 ;;; -*- Package: SYSTEM -*-
2     ;;;
3 ram 1.1 ;;; **********************************************************************
4 ram 1.5 ;;; 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 rtoy 1.54.12.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/foreign.lisp,v 1.54.12.1 2008/11/01 22:40:35 rtoy Exp $")
9 ram 1.5 ;;;
10 ram 1.1 ;;; **********************************************************************
11 wlott 1.3 ;;;
12     (in-package "SYSTEM")
13 ram 1.1
14 ram 1.11 (in-package "ALIEN")
15 wlott 1.3 (export '(load-foreign))
16 wlott 1.4 (in-package "SYSTEM")
17 ram 1.11 (import 'alien:load-foreign)
18 wlott 1.13
19     #+sparc (defconstant foreign-segment-start #xe0000000)
20     #+sparc (defconstant foreign-segment-size #x00100000)
21    
22 ram 1.16 #+hppa (defconstant foreign-segment-start #x10C00000)
23     #+hppa (defconstant foreign-segment-size #x00400000)
24    
25 pmai 1.35 #+(and bsd x86)
26 dtc 1.29 (defconstant foreign-segment-start #x0E000000)
27 pmai 1.35 #+(and bsd x86)
28 dtc 1.29 (defconstant foreign-segment-size #x02000000)
29 ram 1.21
30 wlott 1.3 (defvar *previous-linked-object-file* nil)
31 pmai 1.50 #-(or linux bsd svr4 irix)
32 wlott 1.3 (defvar *foreign-segment-free-pointer* foreign-segment-start)
33 ram 1.1
34 wlott 1.3 (defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C"))
35     (let ((code (char-code #\A)))
36     (loop
37 wlott 1.8 (let ((name (format nil base (unix:unix-getpid) (code-char code))))
38 wlott 1.3 (multiple-value-bind
39     (fd errno)
40 wlott 1.8 (unix:unix-open name
41     (logior unix:o_wronly unix:o_creat unix:o_excl)
42 wlott 1.3 #o666)
43     (cond ((not (null fd))
44 wlott 1.8 (unix:unix-close fd)
45 wlott 1.3 (return name))
46 wlott 1.8 ((not (= errno unix:eexist))
47 wlott 1.3 (error "Could not create temporary file ~S: ~A"
48 wlott 1.8 name (unix:get-unix-error-msg errno)))
49 wlott 1.3
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 ram 1.1
57 pmai 1.40 #+(or (and FreeBSD (not elf)) (and sparc (not svr4)))
58 wlott 1.8 (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 ram 1.1
69 emarsden 1.45 #-(or linux bsd svr4)
70 wlott 1.3 (defun allocate-space-in-foreign-segment (bytes)
71 ram 1.6 (let* ((pagesize-1 (1- (get-page-size)))
72 wlott 1.3 (memory-needed (logandc2 (+ bytes pagesize-1) pagesize-1))
73     (addr (int-sap *foreign-segment-free-pointer*))
74 ram 1.15 (new-ptr (+ *foreign-segment-free-pointer* memory-needed)))
75 wlott 1.3 (when (> new-ptr (+ foreign-segment-start foreign-segment-size))
76     (error "Not enough memory left."))
77     (setf *foreign-segment-free-pointer* new-ptr)
78 wlott 1.10 (allocate-system-memory-at addr memory-needed)
79 wlott 1.3 addr))
80 ram 1.1
81 pw 1.30
82 emarsden 1.45 ;;; 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 pw 1.30 ;;;
86     ;;; The following definitions are taken from
87     ;;; /usr/include/sys/elf_common.h and /usr/include/sys/elf32.h.
88     ;;;
89 pmai 1.50 #+(or linux (and bsd (not darwin)) svr4)
90 pw 1.30 (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 pmai 1.37 ;; 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 pw 1.30 ;; 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 pmai 1.37 ;; 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 pw 1.30 (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 pmai 1.37 (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 pw 1.30
196     (defun elf-executable-p (n)
197 emarsden 1.45 "Given a file type number, determine whether the file is executable."
198 pw 1.30 (= n et-executable))
199    
200 emarsden 1.45 (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 pmai 1.50 ) ;; #+(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 rtoy 1.53 ;;; 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 pmai 1.50 (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 rtoy 1.53 ;;; 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 pmai 1.50 (defun file-shared-library-p (pathname)
321     (with-open-file (obj pathname
322     :direction :input
323     :element-type '(unsigned-byte 8))
324 rtoy 1.53 (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 pmai 1.50 ) ; #+darwin
333 emarsden 1.45
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 pw 1.30 (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 pmai 1.37 (error (format nil "~A is not an ELF file." name)))
369 pw 1.30
370 pmai 1.37 (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 pw 1.30
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 pmai 1.35 (kind (aref line 9)) ; filter out .o file names
408 pw 1.30 (old-address (gethash symbol lisp::*foreign-symbols*)))
409     (unless (or (null old-address) (= address old-address)
410 pmai 1.35 (char= kind #\F))
411 pw 1.30 (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 emarsden 1.45 ) ;; #-(or linux bsd svr4)
416    
417    
418 pw 1.30
419 ram 1.21 ;;; 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 pmai 1.40 #+(or (and FreeBSD (not ELF)) (and sparc (not svr4)))
423 wlott 1.3 (defun load-object-file (name)
424     (format t ";;; Loading object file...~%")
425 wlott 1.8 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
426 wlott 1.3 (unless fd
427 wlott 1.8 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
428 wlott 1.3 (unwind-protect
429 wlott 1.8 (alien:with-alien ((header exec))
430     (unix:unix-read fd
431     (alien:alien-sap header)
432     (alien:alien-size exec :bytes))
433 wlott 1.3 (let* ((len-of-text-and-data
434 wlott 1.8 (+ (alien:slot header 'text) (alien:slot header 'data)))
435 wlott 1.3 (memory-needed
436 wlott 1.8 (+ len-of-text-and-data (alien:slot header 'bss)))
437 wlott 1.3 (addr (allocate-space-in-foreign-segment memory-needed)))
438 wlott 1.8 (unix:unix-read fd addr len-of-text-and-data)))
439     (unix:unix-close fd))))
440 ram 1.1
441 pw 1.30
442 ram 1.16 #+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 ram 1.19 (defconstant reloc-magic #x106)
518     #+hppa
519 pw 1.24 (defconstant cpu-pa-risc1-0 #x20b)
520     #+hppa
521 ram 1.19 (defconstant cpu-pa-risc1-1 #x210)
522 pw 1.24 #+hppa
523     (defconstant cpu-pa-risc-max #x2ff)
524 ram 1.19
525     #+hppa
526 ram 1.16 (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 wlott 1.8 (unix:unix-close fd))))
565 ram 1.1
566 emarsden 1.45 #-(or linux bsd solaris irix)
567     (progn
568 wlott 1.3 (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 pmai 1.35 #+BSD (kind (aref line 9)) ; filter out .o file names
579 wlott 1.3 (old-address (gethash symbol lisp::*foreign-symbols*)))
580 ram 1.21 (unless (or (null old-address) (= address old-address)
581 pmai 1.35 #+BSD (char= kind #\F))
582 wlott 1.3 (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 ram 1.1
587 ram 1.11 (defun load-foreign (files &key
588 ram 1.1 (libraries '("-lc"))
589 ram 1.12 (base-file
590 ram 1.19 #-hpux
591 ram 1.12 (merge-pathnames *command-line-utility-name*
592 ram 1.19 "path:")
593 wlott 1.20 #+hpux "library:cmucl.orig")
594 toy 1.33 (env ext:*environment-list*)
595 moore 1.41 (verbose *load-verbose*))
596 ram 1.11 "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 wlott 1.3 (let ((output-file (pick-temporary-file-name))
606     (symbol-table-file (pick-temporary-file-name))
607 ram 1.19 (error-output (make-string-output-stream))
608     (files (if (atom files) (list files) files)))
609 ram 1.7
610 toy 1.33 (when verbose
611     (format t ";;; Running library:load-foreign.csh...~%")
612     (force-output))
613 ram 1.19 #+hpux
614     (dolist (f files)
615     (with-open-file (stream f :element-type '(unsigned-byte 16))
616 pw 1.24 (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 ram 1.19 (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 wlott 1.14 (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 dtc 1.32 (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 wlott 1.14 libraries))
648     :env env
649     :input nil
650     :output error-output
651     :error :output)))
652 wlott 1.3 (unless proc
653 ram 1.11 (error "Could not run library:load-foreign.csh"))
654 wlott 1.3 (unless (zerop (ext:process-exit-code proc))
655     (system:serve-all-events 0)
656 ram 1.11 (error "library:load-foreign.csh failed:~%~A"
657     (get-output-stream-string error-output)))
658 wlott 1.3 (load-object-file output-file)
659     (parse-symbol-table symbol-table-file)
660 wlott 1.8 (unix:unix-unlink symbol-table-file)
661 wlott 1.3 (let ((old-file *previous-linked-object-file*))
662     (setf *previous-linked-object-file* output-file)
663     (when old-file
664 wlott 1.8 (unix:unix-unlink old-file)))))
665 toy 1.33 (when verbose
666     (format t ";;; Done.~%")
667     (force-output)))
668 ram 1.17
669    
670     (export '(alternate-get-global-address))
671    
672 ram 1.21 (defun alternate-get-global-address (symbol)
673     (declare (type simple-string symbol)
674     (ignore symbol))
675     0)
676 emarsden 1.45 ) ;; #-(or linux bsd solaris irix)
677    
678 ram 1.17
679 emarsden 1.45 ;; Modern dlopen()-based loading of shared libraries
680     #+(or linux bsd solaris irix)
681 ram 1.17 (progn
682    
683 dtc 1.28 (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 dtc 1.27
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 moore 1.41 #-linkage-table
701 pw 1.25 (pushnew #'(lambda () (setq *global-table* nil))
702 dtc 1.27 ext:*after-save-initializations*)
703    
704 pw 1.24 (defvar *dso-linker*
705     #+solaris "/usr/ccs/bin/ld"
706 emarsden 1.45 #-solaris "/usr/bin/ld")
707 ram 1.17
708     (alien:def-alien-routine dlopen system-area-pointer
709 dtc 1.28 (file c-call:c-string) (mode c-call:int))
710 ram 1.17 (alien:def-alien-routine dlsym system-area-pointer
711     (lib system-area-pointer)
712 dtc 1.28 (name c-call:c-string))
713 ram 1.17 (alien:def-alien-routine dlclose void (lib system-area-pointer))
714     (alien:def-alien-routine dlerror c-call:c-string)
715    
716 dtc 1.27 ;;; 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 pw 1.25 (defun ensure-lisp-table-opened ()
724     (unless *global-table*
725     ;; Prevent recursive call if dlopen isn't defined
726 moore 1.42 (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 pw 1.25 (error "Can't open global symbol table: ~S" (dlerror)))))
730    
731 rtoy 1.54 (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 pw 1.25 (ensure-lisp-table-opened)
747 ram 1.17 ; 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 rtoy 1.54 (let* ((filename (namestring (convert-object-file-path file)))
750 moore 1.41 (sap (dlopen filename (logior rtld-now rtld-global))))
751     (cond ((zerop (sap-int sap))
752 gerd 1.44 (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 rtoy 1.54 (return-from load-object-file
758     (values nil (format nil "Can't open object ~S: ~S" file err-string))))
759 gerd 1.44 (dlclose sap)
760 rtoy 1.54 (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 moore 1.41 (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 emarsden 1.48 ;;; 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 moore 1.41 (defun reinitialize-global-table ()
784 emarsden 1.48 (loop for lib-entry in (reverse *global-table*)
785 moore 1.41 for (sap . lib-path) = lib-entry
786 emarsden 1.48 when lib-path
787 rtoy 1.54 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 moore 1.41 (alien:alien-funcall (alien:extern-alien "os_resolve_data_linkage"
812 emarsden 1.48 (alien:function c-call:void))))
813 ram 1.17
814     (defun alternate-get-global-address (symbol)
815 pw 1.25 (ensure-lisp-table-opened)
816 emarsden 1.45 ;; find the symbol in any of the loaded objects,
817 ram 1.17 ;; 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 pw 1.43 (setq result (sap-int (dlsym (caar table) symbol))))
823 ram 1.17 (values result)))
824    
825     (defun load-foreign (files &key
826     (libraries '("-lc"))
827     (base-file nil)
828 toy 1.33 (env ext:*environment-list*)
829     (verbose *load-verbose*))
830 emarsden 1.45 "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 ram 1.17 ;; 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 emarsden 1.45 ;; if passed a single shared object that can be loaded directly via
844     ;; dlopen(), do that instead of using the linker
845 rtoy 1.54 (when (atom files)
846     (when verbose
847     (format t ";;; Opening as shared library ~A ...~%" files))
848 rtoy 1.54.12.1 (multiple-value-bind (ok error-string)
849 rtoy 1.54 (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 moore 1.41
869 rtoy 1.54 (when verbose
870     (format t ";;; Running ~A...~%" *dso-linker*)
871     (force-output))
872 toy 1.33
873 rtoy 1.54 (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 emarsden 1.45
924 rtoy 1.54 #+linkage-table
925     (pushnew #'reinitialize-global-table ext:*after-save-initializations*)
926 emarsden 1.45 ) ;; #+(or linux bsd solaris irix)

  ViewVC Help
Powered by ViewVC 1.1.5