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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.40 - (hide annotations)
Mon May 6 18:02:04 2002 UTC (11 years, 11 months ago) by pmai
Branch: MAIN
CVS Tags: PRE_LINKAGE_TABLE
Changes since 1.39: +15 -14 lines
Changed the OpenBSD port to use dlopen+ld for FFI linkage, like
current Linux and FreeBSD/ELF do, although OpenBSD is still non-ELF.
Also changed the handling of leading underscores in alien names, by
moving the underscore addition to extern-alien-name, where it belongs,
and not foreign-symbol-address-aux.  This brings the x86 port in line
with the other ports, modulo the PVE_stub_ magic.  The changes
necessitate some bootstrapping code for BSD non-ELF platforms.
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.40 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/foreign.lisp,v 1.40 2002/05/06 18:02:04 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     #+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     (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 pw 1.25 (pushnew #'(lambda () (setq *global-table* nil))
620 dtc 1.27 ext:*after-save-initializations*)
621    
622 pw 1.24 (defvar *dso-linker*
623     #+solaris "/usr/ccs/bin/ld"
624 pmai 1.40 #+(or OpenBSD linux irix FreeBSD4) "/usr/bin/ld")
625 ram 1.17
626     (alien:def-alien-routine dlopen system-area-pointer
627 dtc 1.28 (file c-call:c-string) (mode c-call:int))
628 ram 1.17 (alien:def-alien-routine dlsym system-area-pointer
629     (lib system-area-pointer)
630 dtc 1.28 (name c-call:c-string))
631 ram 1.17 (alien:def-alien-routine dlclose void (lib system-area-pointer))
632     (alien:def-alien-routine dlerror c-call:c-string)
633    
634 dtc 1.27 ;;; Ensure we've opened our own binary so can resolve global variables
635     ;;; in the lisp image that come from libraries. This used to happen
636     ;;; only in alternate-get-global-address, and only if no libraries
637     ;;; were dlopened already, but that didn't work if something was
638     ;;; dlopened before any problem global vars were used. So now we do
639     ;;; this in any function that can add to the global-table, as well as
640     ;;; in alternate-get-global-address.
641 pw 1.25 (defun ensure-lisp-table-opened ()
642     (unless *global-table*
643     ;; Prevent recursive call if dlopen isn't defined
644     (setf *global-table* (int-sap 0))
645     (setf *global-table* (list (dlopen nil rtld-lazy)))
646     (when (zerop (system:sap-int (car *global-table*)))
647     (error "Can't open global symbol table: ~S" (dlerror)))))
648    
649 ram 1.17 (defun load-object-file (file)
650 pw 1.25 (ensure-lisp-table-opened)
651 ram 1.17 ; rtld global: so it can find all the symbols previously loaded
652     ; rtld now: that way dlopen will fail if not all symbols are defined.
653     (let ((sap (dlopen file (logior rtld-now rtld-global))))
654     (if (zerop (sap-int sap))
655     (error "Can't open object ~S: ~S" file (dlerror))
656 pw 1.24 (pushnew sap *global-table* :test #'sap=))))
657 ram 1.17
658     (defun alternate-get-global-address (symbol)
659 pw 1.25 (ensure-lisp-table-opened)
660 ram 1.17 ;; find the symbol in any of the loaded obbjects,
661     ;; search in reverse order of loading, later loadings
662     ;; take precedence
663     (let ((result 0))
664     (do ((table *global-table* (cdr table)))
665     ((or (null (car table)) (not (zerop result))))
666     (setq result (sap-int (dlsym (car table) symbol))))
667     (values result)))
668    
669     (defun load-foreign (files &key
670     (libraries '("-lc"))
671     (base-file nil)
672 toy 1.33 (env ext:*environment-list*)
673     (verbose *load-verbose*))
674 ram 1.17 "Load-foreign loads a list of C object files into a running Lisp. The files
675     argument should be a single file or a list of files. The files may be
676     specified as namestrings or as pathnames. The libraries argument should be a
677     list of library files as would be specified to ld. They will be searched in
678     the order given. The default is just \"-lc\", i.e., the C library. The
679     base-file argument is used to specify a file to use as the starting place for
680     defined symbols. The default is the C start up code for Lisp. The env
681     argument is the Unix environment variable definitions for the invocation of
682     the linker. The default is the environment passed to Lisp."
683     ;; Note: dlopen remembers the name of an object, when dlopenin
684     ;; the same name twice, the old objects is reused.
685     (declare (ignore base-file))
686     (let ((output-file (pick-temporary-file-name
687 pw 1.23 (concatenate 'string "/tmp/~D~C" (string (gensym)))))
688 ram 1.17 (error-output (make-string-output-stream)))
689 toy 1.33
690     (when verbose
691     (format t ";;; Running ~A...~%" *dso-linker*)
692     (force-output))
693    
694 ram 1.17 (let ((proc (ext:run-program
695 pw 1.24 *dso-linker*
696 ram 1.17 (list*
697 pmai 1.40 #+(or solaris linux FreeBSD4) "-G"
698     #+(or OpenBSD irix) "-shared"
699 ram 1.17 "-o"
700     output-file
701 pmai 1.34 ;; Cause all specified libs to be loaded in full
702 pmai 1.40 #+(or OpenBSD linux FreeBSD4) "--whole-archive"
703 pmai 1.34 #+solaris "-z" #+solaris "allextract"
704 dtc 1.32 (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 pmai 1.34 ;; Return to default ld behaviour for libs
717     (list
718 pmai 1.40 #+(or OpenBSD linux FreeBSD4)
719     "--no-whole-archive"
720 pmai 1.34 #+solaris "-z" #+solaris "defaultextract")
721 ram 1.17 libraries))
722     :env env
723     :input nil
724     :output error-output
725     :error :output)))
726     (unless proc
727 pw 1.24 (error "Could not run ~A" *dso-linker*))
728 ram 1.17 (unless (zerop (ext:process-exit-code proc))
729     (system:serve-all-events 0)
730 pw 1.24 (error "~A failed:~%~A" *dso-linker*
731 ram 1.17 (get-output-stream-string error-output)))
732     (load-object-file output-file)
733     (unix:unix-unlink output-file)
734     ))
735 toy 1.33 (when verbose
736     (format t ";;; Done.~%")
737     (force-output)))
738 ram 1.17 )

  ViewVC Help
Powered by ViewVC 1.1.5