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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.22.2.5 - (hide annotations)
Sat Mar 23 18:50:00 2002 UTC (12 years ago) by pw
Branch: RELENG_18
CVS Tags: RELEASE_18d
Changes since 1.22.2.4: +124 -43 lines
Mega commit to bring RELENG_18 branch in sync with HEAD in preparation
for release tagging 18d.
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 pw 1.22.2.5 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/foreign.lisp,v 1.22.2.5 2002/03/23 18:50:00 pw 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 pw 1.22.2.5 #+(and bsd x86)
29 pw 1.22.2.3 (defconstant foreign-segment-start #x0E000000)
30 pw 1.22.2.5 #+(and bsd x86)
31 pw 1.22.2.3 (defconstant foreign-segment-size #x02000000)
32 ram 1.21
33 wlott 1.3 (defvar *previous-linked-object-file* nil)
34 dtc 1.22 #-(or 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 pw 1.22.2.5 #+(or OpenBSD (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 ram 1.21 #-(or 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.22.2.3
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 pw 1.22.2.5 #+(or NetBSD (and FreeBSD elf (not FreeBSD4)))
93 pw 1.22.2.3 (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 pw 1.22.2.5 ;; 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.22.2.3 ;; 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 pw 1.22.2.5 ;; 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.22.2.3 (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 pw 1.22.2.5 (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.22.2.3
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 pw 1.22.2.5 (error (format nil "~A is not an ELF file." name)))
230 pw 1.22.2.3
231 pw 1.22.2.5 (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.22.2.3
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 pw 1.22.2.5 (kind (aref line 9)) ; filter out .o file names
269 pw 1.22.2.3 (old-address (gethash symbol lisp::*foreign-symbols*)))
270     (unless (or (null old-address) (= address old-address)
271 pw 1.22.2.5 (char= kind #\F))
272 pw 1.22.2.3 (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 pw 1.22.2.5 ;;; prm- We assume this works for OpenBSD as well, needs testing...
283     #+(or OpenBSD (and FreeBSD (not ELF)) (and sparc (not svr4)))
284 wlott 1.3 (defun load-object-file (name)
285     (format t ";;; Loading object file...~%")
286 wlott 1.8 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
287 wlott 1.3 (unless fd
288 wlott 1.8 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
289 wlott 1.3 (unwind-protect
290 wlott 1.8 (alien:with-alien ((header exec))
291     (unix:unix-read fd
292     (alien:alien-sap header)
293     (alien:alien-size exec :bytes))
294 wlott 1.3 (let* ((len-of-text-and-data
295 wlott 1.8 (+ (alien:slot header 'text) (alien:slot header 'data)))
296 wlott 1.3 (memory-needed
297 wlott 1.8 (+ len-of-text-and-data (alien:slot header 'bss)))
298 wlott 1.3 (addr (allocate-space-in-foreign-segment memory-needed)))
299 wlott 1.8 (unix:unix-read fd addr len-of-text-and-data)))
300     (unix:unix-close fd))))
301 ram 1.1
302 pw 1.22.2.3
303 wlott 1.3 #+pmax
304 wlott 1.8 (alien:def-alien-type filehdr
305     (alien:struct nil
306     (magic c-call:unsigned-short)
307     (nscns c-call:unsigned-short)
308     (timdat c-call:long)
309     (symptr c-call:long)
310     (nsyms c-call:long)
311     (opthdr c-call:unsigned-short)
312     (flags c-call:unsigned-short)))
313 ram 1.1
314 wlott 1.3 #+pmax
315 wlott 1.8 (alien:def-alien-type aouthdr
316     (alien:struct nil
317     (magic c-call:short)
318     (vstamp c-call:short)
319     (tsize c-call:long)
320     (dsize c-call:long)
321     (bsize c-call:long)
322     (entry c-call:long)
323     (text_start c-call:long)
324     (data_start c-call:long)))
325 ram 1.1
326 wlott 1.3 #+pmax
327     (defconstant filhsz 20)
328     #+pmax
329     (defconstant aouthsz 56)
330     #+pmax
331     (defconstant scnhsz 40)
332 ram 1.1
333 wlott 1.3 #+pmax
334     (defun load-object-file (name)
335     (format t ";;; Loading object file...~%")
336 wlott 1.8 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
337 wlott 1.3 (unless fd
338 wlott 1.8 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
339 wlott 1.3 (unwind-protect
340 wlott 1.8 (alien:with-alien ((filehdr filehdr)
341     (aouthdr aouthdr))
342     (unix:unix-read fd
343     (alien:alien-sap filehdr)
344     (alien:alien-size filehdr :bytes))
345     (unix:unix-read fd
346     (alien:alien-sap aouthdr)
347     (alien:alien-size aouthdr :bytes))
348     (let* ((len-of-text-and-data
349     (+ (alien:slot aouthdr 'tsize) (alien:slot aouthdr 'dsize)))
350     (memory-needed
351     (+ len-of-text-and-data (alien:slot aouthdr 'bsize)))
352     (addr (allocate-space-in-foreign-segment memory-needed))
353     (pad-size-1 (if (< (alien:slot aouthdr 'vstamp) 23) 7 15)))
354     (unix:unix-lseek fd
355     (logandc2 (+ filhsz aouthsz
356     (* scnhsz
357     (alien:slot filehdr 'nscns))
358     pad-size-1)
359     pad-size-1)
360     unix:l_set)
361     (unix:unix-read fd addr len-of-text-and-data)))
362 ram 1.16 (unix:unix-close fd))))
363    
364     #+hppa
365     (alien:def-alien-type nil
366     (alien:struct sys_clock
367     (secs c-call:unsigned-int)
368     (nanosecs c-call:unsigned-int)))
369     #+hppa
370     (alien:def-alien-type nil
371     (alien:struct header
372     (system_id c-call:short)
373     (a_magic c-call:short)
374     (version_id c-call:unsigned-int)
375     (file_time (alien:struct sys_clock))
376     (entry_space c-call:unsigned-int)
377     (entry_subspace c-call:unsigned-int)
378     (entry_offset c-call:unsigned-int)
379     (aux_header_location c-call:unsigned-int)
380     (aux_header_size c-call:unsigned-int)
381     (som_length c-call:unsigned-int)
382     (presumed_dp c-call:unsigned-int)
383     (space_location c-call:unsigned-int)
384     (space_total c-call:unsigned-int)
385     (subspace_location c-call:unsigned-int)
386     (subspace_total c-call:unsigned-int)
387     (loader_fixup_location c-call:unsigned-int)
388     (loader_fixup_total c-call:unsigned-int)
389     (space_strings_location c-call:unsigned-int)
390     (space_strings_size c-call:unsigned-int)
391     (init_array_location c-call:unsigned-int)
392     (init_array_total c-call:unsigned-int)
393     (compiler_location c-call:unsigned-int)
394     (compiler_total c-call:unsigned-int)
395     (symbol_location c-call:unsigned-int)
396     (symbol_total c-call:unsigned-int)
397     (fixup_request_location c-call:unsigned-int)
398     (fixup_request_total c-call:unsigned-int)
399     (symbol_strings_location c-call:unsigned-int)
400     (symbol_strings_size c-call:unsigned-int)
401     (unloadable_sp_location c-call:unsigned-int)
402     (unloadable_sp_size c-call:unsigned-int)
403     (checksum c-call:unsigned-int)))
404    
405     #+hppa
406     (alien:def-alien-type nil
407     (alien:struct aux_id
408     #|
409     (mandatory c-call:unsigned-int 1)
410     (copy c-call:unsigned-int 1)
411     (append c-call:unsigned-int 1)
412     (ignore c-call:unsigned-int 1)
413     (reserved c-call:unsigned-int 12)
414     (type c-call:unsigned-int 16)
415     |#
416     (dummy c-call:unsigned-int)
417     (length c-call:unsigned-int)))
418     #+hppa
419     (alien:def-alien-type nil
420     (alien:struct som_exec_auxhdr
421     (som_auxhdr (alien:struct aux_id))
422     (exec_tsize c-call:long)
423     (exec_tmem c-call:long)
424     (exec_tfile c-call:long)
425     (exec_dsize c-call:long)
426     (exec_dmem c-call:long)
427     (exec_dfile c-call:long)
428     (exec_bsize c-call:long)
429     (exec_entry c-call:long)
430     (exec_flags c-call:long)
431     (exec_bfill c-call:long)))
432    
433     #+hppa
434     (alien:def-alien-routine ("bzero" unix-bzero) c-call:void
435     (s alien:system-area-pointer)
436     (n c-call:unsigned-long))
437    
438     #+hppa
439 ram 1.19 (defconstant reloc-magic #x106)
440     #+hppa
441 pw 1.22.2.2 (defconstant cpu-pa-risc1-0 #x20b)
442     #+hppa
443 ram 1.19 (defconstant cpu-pa-risc1-1 #x210)
444 pw 1.22.2.2 #+hppa
445     (defconstant cpu-pa-risc-max #x2ff)
446 ram 1.19
447     #+hppa
448 ram 1.16 (defun load-object-file (name)
449     (format t ";;; Loading object file...~%")
450     (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
451     (unless fd
452     (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
453     (unwind-protect
454     (alien:with-alien ((header (alien:struct som_exec_auxhdr)))
455     (unix:unix-lseek fd (alien:alien-size (alien:struct header) :bytes)
456     unix:l_set)
457     (unix:unix-read fd
458     (alien:alien-sap header)
459     (alien:alien-size (alien:struct som_exec_auxhdr)
460     :bytes))
461     (let* ((tmem (alien:slot header 'exec_tmem))
462     (tsize (alien:slot header 'exec_tsize))
463     (dmem (alien:slot header 'exec_dmem))
464     (dsize (alien:slot header 'exec_dsize))
465     (bsize (alien:slot header 'exec_bsize))
466     (memory-needed (+ tsize dsize bsize (* 2 4096)))
467     (addr (allocate-space-in-foreign-segment memory-needed)))
468     (unix-bzero addr memory-needed) ;force valid
469     (unix:unix-lseek fd (alien:slot header 'exec_tfile) unix:l_set)
470     (unix:unix-read fd (system:int-sap tmem) tsize)
471     (unix:unix-lseek fd (alien:slot header 'exec_dfile) unix:l_set)
472     (unix:unix-read fd (system:int-sap dmem) dsize)
473     (unix-bzero (system:int-sap (+ dmem dsize)) bsize)
474     ;;(format t "tmem ~X tsize ~X dmem ~X dsize ~X bsize ~X~%"
475     ;; tmem tsize dmem dsize bsize)
476     ;;(format t "tfile ~X dfile ~X~%"
477     ;; (alien:slot header 'exec_tfile)
478     ;; (alien:slot header 'exec_dfile))
479     (alien:alien-funcall (alien:extern-alien
480     "sanctify_for_execution"
481     (alien:function c-call:void
482     alien:system-area-pointer
483     c-call:unsigned-long))
484     addr (+ (- dmem tmem) dsize bsize))
485     ))
486 wlott 1.8 (unix:unix-close fd))))
487 ram 1.1
488 pw 1.22.2.5 #-(or linux solaris irix NetBSD (and FreeBSD elf))
489 wlott 1.3 (defun parse-symbol-table (name)
490     (format t ";;; Parsing symbol table...~%")
491     (let ((symbol-table (make-hash-table :test #'equal)))
492     (with-open-file (file name)
493     (loop
494     (let ((line (read-line file nil nil)))
495     (unless line
496     (return))
497     (let* ((symbol (subseq line 11))
498     (address (parse-integer line :end 8 :radix 16))
499 pw 1.22.2.5 #+BSD (kind (aref line 9)) ; filter out .o file names
500 wlott 1.3 (old-address (gethash symbol lisp::*foreign-symbols*)))
501 ram 1.21 (unless (or (null old-address) (= address old-address)
502 pw 1.22.2.5 #+BSD (char= kind #\F))
503 wlott 1.3 (warn "~S moved from #x~8,'0X to #x~8,'0X.~%"
504     symbol old-address address))
505     (setf (gethash symbol symbol-table) address)))))
506     (setf lisp::*foreign-symbols* symbol-table)))
507 ram 1.1
508 dtc 1.22 #-(or linux irix solaris)
509 ram 1.11 (defun load-foreign (files &key
510 ram 1.1 (libraries '("-lc"))
511 ram 1.12 (base-file
512 ram 1.19 #-hpux
513 ram 1.12 (merge-pathnames *command-line-utility-name*
514 ram 1.19 "path:")
515 wlott 1.20 #+hpux "library:cmucl.orig")
516 pw 1.22.2.5 (env ext:*environment-list*)
517     (verbose *load-verbose*))
518 ram 1.11 "Load-foreign loads a list of C object files into a running Lisp. The files
519     argument should be a single file or a list of files. The files may be
520     specified as namestrings or as pathnames. The libraries argument should be a
521     list of library files as would be specified to ld. They will be searched in
522     the order given. The default is just \"-lc\", i.e., the C library. The
523     base-file argument is used to specify a file to use as the starting place for
524     defined symbols. The default is the C start up code for Lisp. The env
525     argument is the Unix environment variable definitions for the invocation of
526     the linker. The default is the environment passed to Lisp."
527 wlott 1.3 (let ((output-file (pick-temporary-file-name))
528     (symbol-table-file (pick-temporary-file-name))
529 ram 1.19 (error-output (make-string-output-stream))
530     (files (if (atom files) (list files) files)))
531 ram 1.7
532 pw 1.22.2.5 (when verbose
533     (format t ";;; Running library:load-foreign.csh...~%")
534     (force-output))
535 ram 1.19 #+hpux
536     (dolist (f files)
537     (with-open-file (stream f :element-type '(unsigned-byte 16))
538 pw 1.22.2.2 (unless (let ((sysid (read-byte stream)))
539     (or (eql sysid cpu-pa-risc1-0)
540     (and (>= sysid cpu-pa-risc1-1)
541     (<= sysid cpu-pa-risc-max))))
542 ram 1.19 (error "Object file is wrong format, so can't load-foreign:~
543     ~% ~S"
544     f))
545     (unless (eql (read-byte stream) reloc-magic)
546     (error "Object file is not relocatable, so can't load-foreign:~
547     ~% ~S"
548     f))))
549    
550 wlott 1.14 (let ((proc (ext:run-program
551     "library:load-foreign.csh"
552     (list* (or *previous-linked-object-file*
553     (namestring (truename base-file)))
554     (format nil "~X"
555     *foreign-segment-free-pointer*)
556     output-file
557     symbol-table-file
558 pw 1.22.2.5 (append (mapcar
559     #'(lambda (name)
560     (or (unix-namestring name)
561     (error 'simple-file-error
562     :pathname name
563     :format-control
564     "File does not exist: ~A."
565     :format-arguments
566     (list name))))
567    
568     files)
569 wlott 1.14 libraries))
570     :env env
571     :input nil
572     :output error-output
573     :error :output)))
574 wlott 1.3 (unless proc
575 ram 1.11 (error "Could not run library:load-foreign.csh"))
576 wlott 1.3 (unless (zerop (ext:process-exit-code proc))
577     (system:serve-all-events 0)
578 ram 1.11 (error "library:load-foreign.csh failed:~%~A"
579     (get-output-stream-string error-output)))
580 wlott 1.3 (load-object-file output-file)
581     (parse-symbol-table symbol-table-file)
582 wlott 1.8 (unix:unix-unlink symbol-table-file)
583 wlott 1.3 (let ((old-file *previous-linked-object-file*))
584     (setf *previous-linked-object-file* output-file)
585     (when old-file
586 wlott 1.8 (unix:unix-unlink old-file)))))
587 pw 1.22.2.5 (when verbose
588     (format t ";;; Done.~%")
589     (force-output)))
590 ram 1.17
591    
592     (export '(alternate-get-global-address))
593    
594 pw 1.22.2.2 #-(or solaris linux irix)
595 ram 1.21 (defun alternate-get-global-address (symbol)
596     (declare (type simple-string symbol)
597     (ignore symbol))
598     0)
599 ram 1.17
600 pw 1.22.2.5 #+(or linux solaris irix FreeBSD4)
601 ram 1.17 (progn
602    
603 pw 1.22.2.2 (defconstant rtld-lazy 1
604     "Lazy function call binding")
605     (defconstant rtld-now 2
606     "Immediate function call binding")
607     #+(and linux glibc2)
608     (defconstant rtld-binding-mask #x3
609     "Mask of binding time value")
610    
611     (defconstant rtld-global #-irix #x100 #+irix 4
612     "If set the symbols of the loaded object and its dependencies are
613     made visible as if the object were linked directly into the program")
614    
615     (defvar *global-table* nil)
616     ;;; Dynamically loaded stuff isn't there upon restoring from a
617     ;;; save--this is primarily for irix, which resolves tzname at
618     ;;; runtime, resulting in *global-table* being set in the saved core
619     ;;; image, resulting in havoc upon restart.
620     (pushnew #'(lambda () (setq *global-table* nil))
621     ext:*after-save-initializations*)
622    
623     (defvar *dso-linker*
624     #+solaris "/usr/ccs/bin/ld"
625 pw 1.22.2.5 #+(or linux irix FreeBSD4) "/usr/bin/ld")
626 ram 1.17
627     (alien:def-alien-routine dlopen system-area-pointer
628 pw 1.22.2.2 (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 pw 1.22.2.2 (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 pw 1.22.2.2 ;;; 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     (defun ensure-lisp-table-opened ()
643     (unless *global-table*
644     ;; Prevent recursive call if dlopen isn't defined
645     (setf *global-table* (int-sap 0))
646     (setf *global-table* (list (dlopen nil rtld-lazy)))
647     (when (zerop (system:sap-int (car *global-table*)))
648     (error "Can't open global symbol table: ~S" (dlerror)))))
649    
650 ram 1.17 (defun load-object-file (file)
651 pw 1.22.2.2 (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     (let ((sap (dlopen file (logior rtld-now rtld-global))))
655     (if (zerop (sap-int sap))
656     (error "Can't open object ~S: ~S" file (dlerror))
657 pw 1.22.2.2 (pushnew sap *global-table* :test #'sap=))))
658 ram 1.17
659     (defun alternate-get-global-address (symbol)
660 pw 1.22.2.2 (ensure-lisp-table-opened)
661 ram 1.17 ;; find the symbol in any of the loaded obbjects,
662     ;; search in reverse order of loading, later loadings
663     ;; take precedence
664     (let ((result 0))
665     (do ((table *global-table* (cdr table)))
666     ((or (null (car table)) (not (zerop result))))
667     (setq result (sap-int (dlsym (car table) symbol))))
668     (values result)))
669    
670     (defun load-foreign (files &key
671     (libraries '("-lc"))
672     (base-file nil)
673 pw 1.22.2.5 (env ext:*environment-list*)
674     (verbose *load-verbose*))
675 ram 1.17 "Load-foreign loads a list of C object files into a running Lisp. The files
676     argument should be a single file or a list of files. The files may be
677     specified as namestrings or as pathnames. The libraries argument should be a
678     list of library files as would be specified to ld. They will be searched in
679     the order given. The default is just \"-lc\", i.e., the C library. The
680     base-file argument is used to specify a file to use as the starting place for
681     defined symbols. The default is the C start up code for Lisp. The env
682     argument is the Unix environment variable definitions for the invocation of
683     the linker. The default is the environment passed to Lisp."
684     ;; Note: dlopen remembers the name of an object, when dlopenin
685     ;; the same name twice, the old objects is reused.
686     (declare (ignore base-file))
687     (let ((output-file (pick-temporary-file-name
688 dtc 1.22.2.1 (concatenate 'string "/tmp/~D~C" (string (gensym)))))
689 ram 1.17 (error-output (make-string-output-stream)))
690 pw 1.22.2.5
691     (when verbose
692     (format t ";;; Running ~A...~%" *dso-linker*)
693     (force-output))
694    
695 ram 1.17 (let ((proc (ext:run-program
696 pw 1.22.2.2 *dso-linker*
697 ram 1.17 (list*
698 pw 1.22.2.5 #+(or solaris linux FreeBSD4) "-G" #+irix "-shared"
699 ram 1.17 "-o"
700     output-file
701 pw 1.22.2.5 ;; Cause all specified libs to be loaded in full
702     #+(or linux FreeBSD4) "--whole-archive"
703     #+solaris "-z" #+solaris "allextract"
704     (append (mapcar
705     #'(lambda (name)
706     (or (unix-namestring name)
707     (error 'simple-file-error
708     :pathname name
709     :format-control
710     "File does not exist: ~A."
711     :format-arguments
712     (list name))))
713     (if (atom files)
714     (list files)
715     files))
716     ;; Return to default ld behaviour for libs
717     (list
718     #+(or linux FreeBSD4) "--no-whole-archive"
719     #+solaris "-z" #+solaris "defaultextract")
720 ram 1.17 libraries))
721     :env env
722     :input nil
723     :output error-output
724     :error :output)))
725     (unless proc
726 pw 1.22.2.2 (error "Could not run ~A" *dso-linker*))
727 ram 1.17 (unless (zerop (ext:process-exit-code proc))
728     (system:serve-all-events 0)
729 pw 1.22.2.2 (error "~A failed:~%~A" *dso-linker*
730 ram 1.17 (get-output-stream-string error-output)))
731     (load-object-file output-file)
732     (unix:unix-unlink output-file)
733     ))
734 pw 1.22.2.5 (when verbose
735     (format t ";;; Done.~%")
736     (force-output)))
737 ram 1.17 )

  ViewVC Help
Powered by ViewVC 1.1.5