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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.44 - (hide annotations)
Mon May 26 14:16:58 2003 UTC (10 years, 10 months ago) by gerd
Branch: MAIN
CVS Tags: snapshot-2003-10, dynamic-extent-base, mod-arith-base, sparc_gencgc_merge, snapshot-2003-11, sparc_gencgc, snapshot-2003-12, snapshot-2004-04, lisp-executable-base
Branch point for: mod-arith-branch, sparc_gencgc_branch, dynamic-extent, lisp-executable
Changes since 1.43: +10 -2 lines
	* src/code/foreign.lisp (load-object-file): Print more
	informative error messages.  From Lynn Quam, on cmucl-imp.
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 gerd 1.44 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/foreign.lisp,v 1.44 2003/05/26 14:16:58 gerd 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     #+pmax (defconstant foreign-segment-start #x00C00000)
23     #+pmax (defconstant foreign-segment-size #x00400000)
24 wlott 1.4
25 ram 1.16 #+hppa (defconstant foreign-segment-start #x10C00000)
26     #+hppa (defconstant foreign-segment-size #x00400000)
27    
28 pmai 1.35 #+(and bsd x86)
29 dtc 1.29 (defconstant foreign-segment-start #x0E000000)
30 pmai 1.35 #+(and bsd x86)
31 dtc 1.29 (defconstant foreign-segment-size #x02000000)
32 ram 1.21
33 wlott 1.3 (defvar *previous-linked-object-file* nil)
34 pmai 1.40 #-(or openbsd linux irix)
35 wlott 1.3 (defvar *foreign-segment-free-pointer* foreign-segment-start)
36 ram 1.1
37 wlott 1.3 (defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C"))
38     (let ((code (char-code #\A)))
39     (loop
40 wlott 1.8 (let ((name (format nil base (unix:unix-getpid) (code-char code))))
41 wlott 1.3 (multiple-value-bind
42     (fd errno)
43 wlott 1.8 (unix:unix-open name
44     (logior unix:o_wronly unix:o_creat unix:o_excl)
45 wlott 1.3 #o666)
46     (cond ((not (null fd))
47 wlott 1.8 (unix:unix-close fd)
48 wlott 1.3 (return name))
49 wlott 1.8 ((not (= errno unix:eexist))
50 wlott 1.3 (error "Could not create temporary file ~S: ~A"
51 wlott 1.8 name (unix:get-unix-error-msg errno)))
52 wlott 1.3
53     ((= code (char-code #\Z))
54     (setf code (char-code #\a)))
55     ((= code (char-code #\z))
56     (return nil))
57     (t
58     (incf code))))))))
59 ram 1.1
60 pmai 1.40 #+(or (and FreeBSD (not elf)) (and sparc (not svr4)))
61 wlott 1.8 (alien:def-alien-type exec
62     (alien:struct nil
63     (magic c-call:unsigned-long)
64     (text c-call:unsigned-long)
65     (data c-call:unsigned-long)
66     (bss c-call:unsigned-long)
67     (syms c-call:unsigned-long)
68     (entry c-call:unsigned-long)
69     (trsize c-call:unsigned-long)
70     (drsize c-call:unsigned-long)))
71 ram 1.1
72 pmai 1.40 #-(or OpenBSD linux svr4)
73 wlott 1.3 (defun allocate-space-in-foreign-segment (bytes)
74 ram 1.6 (let* ((pagesize-1 (1- (get-page-size)))
75 wlott 1.3 (memory-needed (logandc2 (+ bytes pagesize-1) pagesize-1))
76     (addr (int-sap *foreign-segment-free-pointer*))
77 ram 1.15 (new-ptr (+ *foreign-segment-free-pointer* memory-needed)))
78 wlott 1.3 (when (> new-ptr (+ foreign-segment-start foreign-segment-size))
79     (error "Not enough memory left."))
80     (setf *foreign-segment-free-pointer* new-ptr)
81 wlott 1.10 (allocate-system-memory-at addr memory-needed)
82 wlott 1.3 addr))
83 ram 1.1
84 pw 1.30
85     ;;;
86     ;;; Elf object file loading for statically linked CMUCL under
87     ;;; FreeBSD.
88     ;;;
89     ;;; The following definitions are taken from
90     ;;; /usr/include/sys/elf_common.h and /usr/include/sys/elf32.h.
91     ;;;
92 moore 1.39 #+(or NetBSD (and FreeBSD elf (not FreeBSD4)))
93 pw 1.30 (progn
94     (alien:def-alien-type elf-address (alien:unsigned 32))
95     (alien:def-alien-type elf-half-word (alien:unsigned 16))
96     (alien:def-alien-type elf-offset (alien:unsigned 32))
97     (alien:def-alien-type elf-signed-word (alien:integer 32))
98     (alien:def-alien-type elf-word (alien:unsigned 32))
99     (alien:def-alien-type elf-size (alien:unsigned 32))
100    
101     (alien:def-alien-type eheader
102     ;;"Elf file header."
103     (alien:struct nil
104     (elf-ident (alien:array (alien:unsigned 8) 16))
105     (elf-type elf-half-word)
106     (elf-machine elf-half-word)
107     (elf-version elf-word)
108     (elf-entry elf-address)
109     (elf-program-header-offset elf-offset)
110     (elf-section-header-offset elf-offset)
111     (elf-flags elf-word)
112     (elf-header-size elf-half-word)
113     (elf-program-header-entry-size elf-half-word)
114     (elf-program-header-count elf-half-word)
115     (elf-section-header-entry-size elf-half-word)
116     (elf-section-header-count elf-half-word)
117     (elf-section-name-strings elf-half-word)))
118    
119 pmai 1.37 ;; Indices into the elf-ident array, as per SVR4 ABI
120     (defconstant ei-mag0 0) ; Magic number, byte 0
121     (defconstant ei-mag1 1) ; Magic number, byte 1
122     (defconstant ei-mag2 2) ; Magic number, byte 2
123     (defconstant ei-mag3 3) ; Magic number, byte 3
124     (defconstant ei-class 4) ; class of machine
125     (defconstant ei-data 5) ; data format
126     (defconstant ei-version 6) ; ELF format version
127     (defconstant ei-osabi 7) ; Operating system / ABI identification
128     (defconstant ei-abiversion 8) ; ABI version
129     (defconstant ei-pad 9) ; Start of padding
130     (defconstant ei-nident 16) ; Size of elf-ident array
131    
132 pw 1.30 ;; values for elf-type
133     (defconstant et-relocatable 1)
134     (defconstant et-executable 2)
135     (defconstant et-shared-object 3)
136     (defconstant et-core-file 4)
137    
138 pmai 1.37 ;; values for elf-ident[ei-osabi]
139     (defconstant elfosabi-sysv 0)
140     (defconstant elfosabi-hpux 1)
141     (defconstant elfosabi-netbsd 2)
142     (defconstant elfosabi-linux 3)
143     (defconstant elfosabi-hurd 4)
144     (defconstant elfosabi-86open 5)
145     (defconstant elfosabi-solaris 6)
146     (defconstant elfosabi-monterey 7)
147     (defconstant elfosabi-irix 8)
148     (defconstant elfosabi-freebsd 9)
149     (defconstant elfosabi-tru64 10)
150     (defconstant elfosabi-modesto 11)
151     (defconstant elfosabi-openbsd 12)
152     (defconstant elfosabi-arm 97)
153     (defconstant elfosabi-standalone 255)
154    
155 pw 1.30 (alien:def-alien-type pheader
156     ;;"Program header."
157     (alien:struct nil
158     (p-type elf-word) ; Entry type.
159     (p-offset elf-offset) ; File offset of contents.
160     (p-virtual-address elf-address) ; Virtual address in mem. image.
161     (p-physical-address elf-address) ; Physical address (not used).
162     (p-file-size elf-size) ; Size of contents in file.
163     (p-memory-size elf-size) ; Size of contents in memory.
164     (p-flags elf-word) ; Access permission flags.
165     (p-alignment elf-size))) ; Alignment in memory and file.
166    
167     (defconstant +elf-magic+
168     (make-array 4 :element-type '(unsigned-byte 8)
169     :initial-contents '(127 69 76 70))) ; 0x7f-E-L-F
170     (defun elf-p (h)
171     "Make sure the header starts with the ELF magic value."
172     (dotimes (i 4 t)
173     (unless (= (alien:deref h i) (aref +elf-magic+ i))
174     (return nil))))
175    
176 pmai 1.37 (defun elf-osabi (h)
177     "Return the `osabi' field in the padding of the ELF file."
178     (alien:deref h ei-osabi))
179    
180     (defun elf-osabi-name (id)
181     (cond
182     ((eql id elfosabi-sysv) "Unix System V ABI")
183     ((eql id elfosabi-hpux) "HP-UX")
184     ((eql id elfosabi-netbsd) "NetBSD")
185     ((eql id elfosabi-linux) "Linux")
186     ((eql id elfosabi-hurd) "GNU/Hurd")
187     ((eql id elfosabi-86open) "86Open common IA32 ABI")
188     ((eql id elfosabi-solaris) "Solaris")
189     ((eql id elfosabi-monterey) "Monterey")
190     ((eql id elfosabi-irix) "IRIX")
191     ((eql id elfosabi-freebsd) "FreeBSD")
192     ((eql id elfosabi-tru64) "Tru64 Unix")
193     ((eql id elfosabi-modesto) "Novell Modesto")
194     ((eql id elfosabi-openbsd) "OpenBSD")
195     ((eql id elfosabi-arm) "ARM")
196     ((eql id elfosabi-standalone) "Standalone/Embedded")
197     (t (format nil "Unknown ABI (~D)" id))))
198 pw 1.30
199     (defun elf-executable-p (n)
200     "Given a file type number, determine if the file is executable."
201     (= n et-executable))
202    
203     (defun load-object-file (name)
204     ;; NAME designates a tempory file created by ld via "load-foreign.csh".
205     ;; Its contents are in a form suitable for stuffing into memory for
206     ;; execution. This function extracts the location and size of the
207     ;; relevant bits and reads them into memory.
208    
209     #|| library:load-foreign.csh
210     #!/bin/csh -fx
211     ld -N -R $argv[1] -Ttext $argv[2] -o $argv[3] $argv[5-]
212     if ($status != 0) exit 1
213    
214     nm -gp $argv[3] > $argv[4]
215     if ($status != 0) exit 2
216     exit 0
217     ||#
218    
219     (format t ";;; Loading object file...~%")
220     (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
221     (unless fd
222     (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
223     (unwind-protect
224     (alien:with-alien ((header eheader))
225     (unix:unix-read fd
226     (alien:alien-sap header)
227     (alien:alien-size eheader :bytes))
228     (unless (elf-p (alien:slot header 'elf-ident))
229 pmai 1.37 (error (format nil "~A is not an ELF file." name)))
230 pw 1.30
231 pmai 1.37 (let ((osabi (elf-osabi (alien:slot header 'elf-ident)))
232     (expected-osabi #+NetBSD elfosabi-netbsd
233     #+FreeBSD elfosabi-freebsd))
234     (unless (= osabi expected-osabi)
235     (error "~A is not a ~A executable, it's a ~A executable."
236     name
237     (elf-osabi-name expected-osabi)
238     (elf-osabi-name osabi))))
239 pw 1.30
240     (unless (elf-executable-p (alien:slot header 'elf-type))
241     (error (format nil "~A is not executable." name)))
242    
243     (alien:with-alien ((program-header pheader))
244     (unix:unix-read fd
245     (alien:alien-sap program-header)
246     (alien:alien-size pheader :bytes))
247     (let* ((addr (system::allocate-space-in-foreign-segment
248     (alien:slot program-header 'p-memory-size))))
249     (unix:unix-lseek
250     fd (alien:slot program-header 'p-offset) unix:l_set)
251     (unix:unix-read
252     fd addr (alien:slot program-header 'p-file-size)))))
253     (unix:unix-close fd))))
254    
255     (defun parse-symbol-table (name)
256     "Parse symbol table file created by load-foreign script. Modified
257     to skip undefined symbols which don't have an address."
258     (format t ";;; Parsing symbol table...~%")
259     (let ((symbol-table (make-hash-table :test #'equal)))
260     (with-open-file (file name)
261     (loop
262     (let ((line (read-line file nil nil)))
263     (unless line
264     (return))
265     (unless (eql (aref line 0) #\space) ; Skip undefined symbols....
266     (let* ((symbol (subseq line 11))
267     (address (parse-integer line :end 8 :radix 16))
268 pmai 1.35 (kind (aref line 9)) ; filter out .o file names
269 pw 1.30 (old-address (gethash symbol lisp::*foreign-symbols*)))
270     (unless (or (null old-address) (= address old-address)
271 pmai 1.35 (char= kind #\F))
272 pw 1.30 (warn "~S moved from #x~8,'0X to #x~8,'0X.~%"
273     symbol old-address address))
274     (setf (gethash symbol symbol-table) address))))))
275     (setf lisp::*foreign-symbols* symbol-table)))
276     )
277    
278    
279 ram 1.21 ;;; pw-- This seems to work for FreeBSD. The MAGIC field is not tested
280     ;;; for correct file format so it may croak if ld fails to produce the
281     ;;; expected results. It is probably good enough for now.
282 pmai 1.40 #+(or (and FreeBSD (not ELF)) (and sparc (not svr4)))
283 wlott 1.3 (defun load-object-file (name)
284     (format t ";;; Loading object file...~%")
285 wlott 1.8 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
286 wlott 1.3 (unless fd
287 wlott 1.8 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
288 wlott 1.3 (unwind-protect
289 wlott 1.8 (alien:with-alien ((header exec))
290     (unix:unix-read fd
291     (alien:alien-sap header)
292     (alien:alien-size exec :bytes))
293 wlott 1.3 (let* ((len-of-text-and-data
294 wlott 1.8 (+ (alien:slot header 'text) (alien:slot header 'data)))
295 wlott 1.3 (memory-needed
296 wlott 1.8 (+ len-of-text-and-data (alien:slot header 'bss)))
297 wlott 1.3 (addr (allocate-space-in-foreign-segment memory-needed)))
298 wlott 1.8 (unix:unix-read fd addr len-of-text-and-data)))
299     (unix:unix-close fd))))
300 ram 1.1
301 pw 1.30
302 wlott 1.3 #+pmax
303 wlott 1.8 (alien:def-alien-type filehdr
304     (alien:struct nil
305     (magic c-call:unsigned-short)
306     (nscns c-call:unsigned-short)
307     (timdat c-call:long)
308     (symptr c-call:long)
309     (nsyms c-call:long)
310     (opthdr c-call:unsigned-short)
311     (flags c-call:unsigned-short)))
312 ram 1.1
313 wlott 1.3 #+pmax
314 wlott 1.8 (alien:def-alien-type aouthdr
315     (alien:struct nil
316     (magic c-call:short)
317     (vstamp c-call:short)
318     (tsize c-call:long)
319     (dsize c-call:long)
320     (bsize c-call:long)
321     (entry c-call:long)
322     (text_start c-call:long)
323     (data_start c-call:long)))
324 ram 1.1
325 wlott 1.3 #+pmax
326     (defconstant filhsz 20)
327     #+pmax
328     (defconstant aouthsz 56)
329     #+pmax
330     (defconstant scnhsz 40)
331 ram 1.1
332 wlott 1.3 #+pmax
333     (defun load-object-file (name)
334     (format t ";;; Loading object file...~%")
335 wlott 1.8 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
336 wlott 1.3 (unless fd
337 wlott 1.8 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
338 wlott 1.3 (unwind-protect
339 wlott 1.8 (alien:with-alien ((filehdr filehdr)
340     (aouthdr aouthdr))
341     (unix:unix-read fd
342     (alien:alien-sap filehdr)
343     (alien:alien-size filehdr :bytes))
344     (unix:unix-read fd
345     (alien:alien-sap aouthdr)
346     (alien:alien-size aouthdr :bytes))
347     (let* ((len-of-text-and-data
348     (+ (alien:slot aouthdr 'tsize) (alien:slot aouthdr 'dsize)))
349     (memory-needed
350     (+ len-of-text-and-data (alien:slot aouthdr 'bsize)))
351     (addr (allocate-space-in-foreign-segment memory-needed))
352     (pad-size-1 (if (< (alien:slot aouthdr 'vstamp) 23) 7 15)))
353     (unix:unix-lseek fd
354     (logandc2 (+ filhsz aouthsz
355     (* scnhsz
356     (alien:slot filehdr 'nscns))
357     pad-size-1)
358     pad-size-1)
359     unix:l_set)
360     (unix:unix-read fd addr len-of-text-and-data)))
361 ram 1.16 (unix:unix-close fd))))
362    
363     #+hppa
364     (alien:def-alien-type nil
365     (alien:struct sys_clock
366     (secs c-call:unsigned-int)
367     (nanosecs c-call:unsigned-int)))
368     #+hppa
369     (alien:def-alien-type nil
370     (alien:struct header
371     (system_id c-call:short)
372     (a_magic c-call:short)
373     (version_id c-call:unsigned-int)
374     (file_time (alien:struct sys_clock))
375     (entry_space c-call:unsigned-int)
376     (entry_subspace c-call:unsigned-int)
377     (entry_offset c-call:unsigned-int)
378     (aux_header_location c-call:unsigned-int)
379     (aux_header_size c-call:unsigned-int)
380     (som_length c-call:unsigned-int)
381     (presumed_dp c-call:unsigned-int)
382     (space_location c-call:unsigned-int)
383     (space_total c-call:unsigned-int)
384     (subspace_location c-call:unsigned-int)
385     (subspace_total c-call:unsigned-int)
386     (loader_fixup_location c-call:unsigned-int)
387     (loader_fixup_total c-call:unsigned-int)
388     (space_strings_location c-call:unsigned-int)
389     (space_strings_size c-call:unsigned-int)
390     (init_array_location c-call:unsigned-int)
391     (init_array_total c-call:unsigned-int)
392     (compiler_location c-call:unsigned-int)
393     (compiler_total c-call:unsigned-int)
394     (symbol_location c-call:unsigned-int)
395     (symbol_total c-call:unsigned-int)
396     (fixup_request_location c-call:unsigned-int)
397     (fixup_request_total c-call:unsigned-int)
398     (symbol_strings_location c-call:unsigned-int)
399     (symbol_strings_size c-call:unsigned-int)
400     (unloadable_sp_location c-call:unsigned-int)
401     (unloadable_sp_size c-call:unsigned-int)
402     (checksum c-call:unsigned-int)))
403    
404     #+hppa
405     (alien:def-alien-type nil
406     (alien:struct aux_id
407     #|
408     (mandatory c-call:unsigned-int 1)
409     (copy c-call:unsigned-int 1)
410     (append c-call:unsigned-int 1)
411     (ignore c-call:unsigned-int 1)
412     (reserved c-call:unsigned-int 12)
413     (type c-call:unsigned-int 16)
414     |#
415     (dummy c-call:unsigned-int)
416     (length c-call:unsigned-int)))
417     #+hppa
418     (alien:def-alien-type nil
419     (alien:struct som_exec_auxhdr
420     (som_auxhdr (alien:struct aux_id))
421     (exec_tsize c-call:long)
422     (exec_tmem c-call:long)
423     (exec_tfile c-call:long)
424     (exec_dsize c-call:long)
425     (exec_dmem c-call:long)
426     (exec_dfile c-call:long)
427     (exec_bsize c-call:long)
428     (exec_entry c-call:long)
429     (exec_flags c-call:long)
430     (exec_bfill c-call:long)))
431    
432     #+hppa
433     (alien:def-alien-routine ("bzero" unix-bzero) c-call:void
434     (s alien:system-area-pointer)
435     (n c-call:unsigned-long))
436    
437     #+hppa
438 ram 1.19 (defconstant reloc-magic #x106)
439     #+hppa
440 pw 1.24 (defconstant cpu-pa-risc1-0 #x20b)
441     #+hppa
442 ram 1.19 (defconstant cpu-pa-risc1-1 #x210)
443 pw 1.24 #+hppa
444     (defconstant cpu-pa-risc-max #x2ff)
445 ram 1.19
446     #+hppa
447 ram 1.16 (defun load-object-file (name)
448     (format t ";;; Loading object file...~%")
449     (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
450     (unless fd
451     (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
452     (unwind-protect
453     (alien:with-alien ((header (alien:struct som_exec_auxhdr)))
454     (unix:unix-lseek fd (alien:alien-size (alien:struct header) :bytes)
455     unix:l_set)
456     (unix:unix-read fd
457     (alien:alien-sap header)
458     (alien:alien-size (alien:struct som_exec_auxhdr)
459     :bytes))
460     (let* ((tmem (alien:slot header 'exec_tmem))
461     (tsize (alien:slot header 'exec_tsize))
462     (dmem (alien:slot header 'exec_dmem))
463     (dsize (alien:slot header 'exec_dsize))
464     (bsize (alien:slot header 'exec_bsize))
465     (memory-needed (+ tsize dsize bsize (* 2 4096)))
466     (addr (allocate-space-in-foreign-segment memory-needed)))
467     (unix-bzero addr memory-needed) ;force valid
468     (unix:unix-lseek fd (alien:slot header 'exec_tfile) unix:l_set)
469     (unix:unix-read fd (system:int-sap tmem) tsize)
470     (unix:unix-lseek fd (alien:slot header 'exec_dfile) unix:l_set)
471     (unix:unix-read fd (system:int-sap dmem) dsize)
472     (unix-bzero (system:int-sap (+ dmem dsize)) bsize)
473     ;;(format t "tmem ~X tsize ~X dmem ~X dsize ~X bsize ~X~%"
474     ;; tmem tsize dmem dsize bsize)
475     ;;(format t "tfile ~X dfile ~X~%"
476     ;; (alien:slot header 'exec_tfile)
477     ;; (alien:slot header 'exec_dfile))
478     (alien:alien-funcall (alien:extern-alien
479     "sanctify_for_execution"
480     (alien:function c-call:void
481     alien:system-area-pointer
482     c-call:unsigned-long))
483     addr (+ (- dmem tmem) dsize bsize))
484     ))
485 wlott 1.8 (unix:unix-close fd))))
486 ram 1.1
487 pmai 1.40 #-(or OpenBSD linux solaris irix NetBSD (and FreeBSD elf))
488 wlott 1.3 (defun parse-symbol-table (name)
489     (format t ";;; Parsing symbol table...~%")
490     (let ((symbol-table (make-hash-table :test #'equal)))
491     (with-open-file (file name)
492     (loop
493     (let ((line (read-line file nil nil)))
494     (unless line
495     (return))
496     (let* ((symbol (subseq line 11))
497     (address (parse-integer line :end 8 :radix 16))
498 pmai 1.35 #+BSD (kind (aref line 9)) ; filter out .o file names
499 wlott 1.3 (old-address (gethash symbol lisp::*foreign-symbols*)))
500 ram 1.21 (unless (or (null old-address) (= address old-address)
501 pmai 1.35 #+BSD (char= kind #\F))
502 wlott 1.3 (warn "~S moved from #x~8,'0X to #x~8,'0X.~%"
503     symbol old-address address))
504     (setf (gethash symbol symbol-table) address)))))
505     (setf lisp::*foreign-symbols* symbol-table)))
506 ram 1.1
507 pmai 1.40 #-(or OpenBSD linux irix solaris)
508 ram 1.11 (defun load-foreign (files &key
509 ram 1.1 (libraries '("-lc"))
510 ram 1.12 (base-file
511 ram 1.19 #-hpux
512 ram 1.12 (merge-pathnames *command-line-utility-name*
513 ram 1.19 "path:")
514 wlott 1.20 #+hpux "library:cmucl.orig")
515 toy 1.33 (env ext:*environment-list*)
516 moore 1.41 (verbose *load-verbose*))
517 ram 1.11 "Load-foreign loads a list of C object files into a running Lisp. The files
518     argument should be a single file or a list of files. The files may be
519     specified as namestrings or as pathnames. The libraries argument should be a
520     list of library files as would be specified to ld. They will be searched in
521     the order given. The default is just \"-lc\", i.e., the C library. The
522     base-file argument is used to specify a file to use as the starting place for
523     defined symbols. The default is the C start up code for Lisp. The env
524     argument is the Unix environment variable definitions for the invocation of
525     the linker. The default is the environment passed to Lisp."
526 wlott 1.3 (let ((output-file (pick-temporary-file-name))
527     (symbol-table-file (pick-temporary-file-name))
528 ram 1.19 (error-output (make-string-output-stream))
529     (files (if (atom files) (list files) files)))
530 ram 1.7
531 toy 1.33 (when verbose
532     (format t ";;; Running library:load-foreign.csh...~%")
533     (force-output))
534 ram 1.19 #+hpux
535     (dolist (f files)
536     (with-open-file (stream f :element-type '(unsigned-byte 16))
537 pw 1.24 (unless (let ((sysid (read-byte stream)))
538     (or (eql sysid cpu-pa-risc1-0)
539     (and (>= sysid cpu-pa-risc1-1)
540     (<= sysid cpu-pa-risc-max))))
541 ram 1.19 (error "Object file is wrong format, so can't load-foreign:~
542     ~% ~S"
543     f))
544     (unless (eql (read-byte stream) reloc-magic)
545     (error "Object file is not relocatable, so can't load-foreign:~
546     ~% ~S"
547     f))))
548    
549 wlott 1.14 (let ((proc (ext:run-program
550     "library:load-foreign.csh"
551     (list* (or *previous-linked-object-file*
552     (namestring (truename base-file)))
553     (format nil "~X"
554     *foreign-segment-free-pointer*)
555     output-file
556     symbol-table-file
557 dtc 1.32 (append (mapcar
558     #'(lambda (name)
559     (or (unix-namestring name)
560     (error 'simple-file-error
561     :pathname name
562     :format-control
563     "File does not exist: ~A."
564     :format-arguments
565     (list name))))
566    
567     files)
568 wlott 1.14 libraries))
569     :env env
570     :input nil
571     :output error-output
572     :error :output)))
573 wlott 1.3 (unless proc
574 ram 1.11 (error "Could not run library:load-foreign.csh"))
575 wlott 1.3 (unless (zerop (ext:process-exit-code proc))
576     (system:serve-all-events 0)
577 ram 1.11 (error "library:load-foreign.csh failed:~%~A"
578     (get-output-stream-string error-output)))
579 wlott 1.3 (load-object-file output-file)
580     (parse-symbol-table symbol-table-file)
581 wlott 1.8 (unix:unix-unlink symbol-table-file)
582 wlott 1.3 (let ((old-file *previous-linked-object-file*))
583     (setf *previous-linked-object-file* output-file)
584     (when old-file
585 wlott 1.8 (unix:unix-unlink old-file)))))
586 toy 1.33 (when verbose
587     (format t ";;; Done.~%")
588     (force-output)))
589 ram 1.17
590    
591     (export '(alternate-get-global-address))
592    
593 pmai 1.40 #-(or OpenBSD linux solaris irix)
594 ram 1.21 (defun alternate-get-global-address (symbol)
595     (declare (type simple-string symbol)
596     (ignore symbol))
597     0)
598 ram 1.17
599 pmai 1.40 #+(or OpenBSD linux solaris irix FreeBSD4)
600 ram 1.17 (progn
601    
602 dtc 1.28 (defconstant rtld-lazy 1
603     "Lazy function call binding")
604     (defconstant rtld-now 2
605     "Immediate function call binding")
606     #+(and linux glibc2)
607     (defconstant rtld-binding-mask #x3
608     "Mask of binding time value")
609    
610     (defconstant rtld-global #-irix #x100 #+irix 4
611     "If set the symbols of the loaded object and its dependencies are
612     made visible as if the object were linked directly into the program")
613 dtc 1.27
614     (defvar *global-table* nil)
615     ;;; Dynamically loaded stuff isn't there upon restoring from a
616     ;;; save--this is primarily for irix, which resolves tzname at
617     ;;; runtime, resulting in *global-table* being set in the saved core
618     ;;; image, resulting in havoc upon restart.
619 moore 1.41 #-linkage-table
620 pw 1.25 (pushnew #'(lambda () (setq *global-table* nil))
621 dtc 1.27 ext:*after-save-initializations*)
622    
623 pw 1.24 (defvar *dso-linker*
624     #+solaris "/usr/ccs/bin/ld"
625 pmai 1.40 #+(or OpenBSD linux irix FreeBSD4) "/usr/bin/ld")
626 ram 1.17
627     (alien:def-alien-routine dlopen system-area-pointer
628 dtc 1.28 (file c-call:c-string) (mode c-call:int))
629 ram 1.17 (alien:def-alien-routine dlsym system-area-pointer
630     (lib system-area-pointer)
631 dtc 1.28 (name c-call:c-string))
632 ram 1.17 (alien:def-alien-routine dlclose void (lib system-area-pointer))
633     (alien:def-alien-routine dlerror c-call:c-string)
634    
635 dtc 1.27 ;;; Ensure we've opened our own binary so can resolve global variables
636     ;;; in the lisp image that come from libraries. This used to happen
637     ;;; only in alternate-get-global-address, and only if no libraries
638     ;;; were dlopened already, but that didn't work if something was
639     ;;; dlopened before any problem global vars were used. So now we do
640     ;;; this in any function that can add to the global-table, as well as
641     ;;; in alternate-get-global-address.
642 pw 1.25 (defun ensure-lisp-table-opened ()
643     (unless *global-table*
644     ;; Prevent recursive call if dlopen isn't defined
645 moore 1.42 (setf *global-table* (acons (int-sap 0) nil nil))
646     (setf *global-table* (acons (dlopen nil rtld-lazy) nil nil))
647     (when (zerop (system:sap-int (caar *global-table*)))
648 pw 1.25 (error "Can't open global symbol table: ~S" (dlerror)))))
649    
650 ram 1.17 (defun load-object-file (file)
651 pw 1.25 (ensure-lisp-table-opened)
652 ram 1.17 ; rtld global: so it can find all the symbols previously loaded
653     ; rtld now: that way dlopen will fail if not all symbols are defined.
654 moore 1.41 (let* ((filename (namestring file ))
655     (sap (dlopen filename (logior rtld-now rtld-global))))
656     (cond ((zerop (sap-int sap))
657 gerd 1.44 (let ((err-string (dlerror))
658     (sap (dlopen filename (logior rtld-lazy rtld-global))))
659     ;; For some reason dlerror always seems to return NIL,
660     ;; which isn't very informative.
661     (when (zerop (sap-int sap))
662     (error "Can't open object ~S: ~S" file err-string))
663     (dlclose sap)
664     (error "LOAD-OBJECT-FILE: Unresolved symbols in file ~S: ~S"
665     file err-string)))
666 moore 1.41 ((null (assoc sap *global-table* :test #'sap=))
667     (setf *global-table* (acons sap file *global-table*)))
668     (t nil))))
669    
670     ;;; Clear close all dlopened libraries and clear out the entries in
671     ;;; *global-table*, prior to doing a save-lisp.
672    
673     (defun close-global-table ()
674     (loop for lib-entry in *global-table*
675     for (sap) = lib-entry
676     do (progn
677     (dlclose sap)
678     ;; Probably not necessary, but neater than leaving around
679     ;; stale handles in the saved image.
680     (setf (car lib-entry) (int-sap 0)))))
681    
682     ;;; Open all the libraries in *global-table*
683     (defun reinitialize-global-table ()
684     (loop for lib-entry in *global-table*
685     for (sap . lib-path) = lib-entry
686     for new-sap = (dlopen (namestring lib-path)
687     (logior rtld-now rtld-global))
688     do (progn
689     (when (zerop (sap-int new-sap))
690     ;; We're going down
691     (error "Couldn't open library ~S: ~S" lib-path (dlerror)))
692     (setf (car lib-entry) new-sap)))
693     (alien:alien-funcall (alien:extern-alien "os_resolve_data_linkage"
694     (alien:function c-call:void))))
695 ram 1.17
696     (defun alternate-get-global-address (symbol)
697 pw 1.25 (ensure-lisp-table-opened)
698 ram 1.17 ;; find the symbol in any of the loaded obbjects,
699     ;; search in reverse order of loading, later loadings
700     ;; take precedence
701     (let ((result 0))
702     (do ((table *global-table* (cdr table)))
703     ((or (null (car table)) (not (zerop result))))
704 pw 1.43 (setq result (sap-int (dlsym (caar table) symbol))))
705 ram 1.17 (values result)))
706    
707     (defun load-foreign (files &key
708     (libraries '("-lc"))
709     (base-file nil)
710 toy 1.33 (env ext:*environment-list*)
711     (verbose *load-verbose*))
712 ram 1.17 "Load-foreign loads a list of C object files into a running Lisp. The files
713     argument should be a single file or a list of files. The files may be
714     specified as namestrings or as pathnames. The libraries argument should be a
715     list of library files as would be specified to ld. They will be searched in
716     the order given. The default is just \"-lc\", i.e., the C library. The
717     base-file argument is used to specify a file to use as the starting place for
718     defined symbols. The default is the C start up code for Lisp. The env
719     argument is the Unix environment variable definitions for the invocation of
720     the linker. The default is the environment passed to Lisp."
721     ;; Note: dlopen remembers the name of an object, when dlopenin
722     ;; the same name twice, the old objects is reused.
723     (declare (ignore base-file))
724     (let ((output-file (pick-temporary-file-name
725 pw 1.23 (concatenate 'string "/tmp/~D~C" (string (gensym)))))
726 ram 1.17 (error-output (make-string-output-stream)))
727 moore 1.41
728 toy 1.33 (when verbose
729     (format t ";;; Running ~A...~%" *dso-linker*)
730     (force-output))
731    
732 ram 1.17 (let ((proc (ext:run-program
733 pw 1.24 *dso-linker*
734 ram 1.17 (list*
735 pmai 1.40 #+(or solaris linux FreeBSD4) "-G"
736     #+(or OpenBSD irix) "-shared"
737 ram 1.17 "-o"
738     output-file
739 pmai 1.34 ;; Cause all specified libs to be loaded in full
740 pmai 1.40 #+(or OpenBSD linux FreeBSD4) "--whole-archive"
741 pmai 1.34 #+solaris "-z" #+solaris "allextract"
742 dtc 1.32 (append (mapcar
743     #'(lambda (name)
744     (or (unix-namestring name)
745     (error 'simple-file-error
746     :pathname name
747     :format-control
748     "File does not exist: ~A."
749     :format-arguments
750     (list name))))
751     (if (atom files)
752     (list files)
753     files))
754 pmai 1.34 ;; Return to default ld behaviour for libs
755     (list
756 pmai 1.40 #+(or OpenBSD linux FreeBSD4)
757     "--no-whole-archive"
758 pmai 1.34 #+solaris "-z" #+solaris "defaultextract")
759 ram 1.17 libraries))
760     :env env
761     :input nil
762     :output error-output
763     :error :output)))
764     (unless proc
765 pw 1.24 (error "Could not run ~A" *dso-linker*))
766 ram 1.17 (unless (zerop (ext:process-exit-code proc))
767     (system:serve-all-events 0)
768 pw 1.24 (error "~A failed:~%~A" *dso-linker*
769 ram 1.17 (get-output-stream-string error-output)))
770     (load-object-file output-file)
771     (unix:unix-unlink output-file)
772     ))
773 toy 1.33 (when verbose
774     (format t ";;; Done.~%")
775     (force-output)))
776 ram 1.17 )

  ViewVC Help
Powered by ViewVC 1.1.5