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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.50 - (hide annotations)
Sun Jul 25 19:32:37 2004 UTC (9 years, 8 months ago) by pmai
Branch: MAIN
CVS Tags: release-19b-pre1, snapshot-2004-10, snapshot-2004-08, snapshot-2004-09, snapshot-2004-12, snapshot-2004-11, snapshot-2005-03, release-19b-base, snapshot-2005-01, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02
Branch point for: release-19b-branch, ppc_gencgc_branch
Changes since 1.49: +56 -4 lines
This commit adds the remainder of the outstanding PPC/Darwin port merge.

Besides support for Darwin foreign loading, and updates to the ppc-vm
and bsd-os files, this commit removes unix:unix-errno as a foreign variable
and replaces it with a function named unix-errno, and a (setf unix-errno).
This makes both glibc support cleaner, and enables ports like PPC/Darwin
(and the upcoming win32 port) which have no easy way of accessing errno as
a foreign variable able to support this functionality at all.

The current implementation of this is rather make-shift, it would likely
be much cleaner to go the SBCL way and mediate all access to errno via
defined functions in the C runtime.

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

  ViewVC Help
Powered by ViewVC 1.1.5