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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.31 - (hide annotations)
Wed Sep 27 11:10:00 2000 UTC (13 years, 6 months ago) by dtc
Branch: MAIN
Changes since 1.30: +3 -3 lines
The library files given to load-foreign are for input and
unix-namestring needs to try and verify their existence otherwise
search paths will not be enumerated and the files may not be found.
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 dtc 1.31 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/foreign.lisp,v 1.31 2000/09/27 11:10:00 dtc 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 dtc 1.29 #+(and freebsd x86)
29     (defconstant foreign-segment-start #x0E000000)
30     #+(and freebsd x86)
31     (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.30 #+(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 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.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     #+(and FreeBSD elf)
93     (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     ;; values for elf-type
120     (defconstant et-relocatable 1)
121     (defconstant et-executable 2)
122     (defconstant et-shared-object 3)
123     (defconstant et-core-file 4)
124    
125     (alien:def-alien-type pheader
126     ;;"Program header."
127     (alien:struct nil
128     (p-type elf-word) ; Entry type.
129     (p-offset elf-offset) ; File offset of contents.
130     (p-virtual-address elf-address) ; Virtual address in mem. image.
131     (p-physical-address elf-address) ; Physical address (not used).
132     (p-file-size elf-size) ; Size of contents in file.
133     (p-memory-size elf-size) ; Size of contents in memory.
134     (p-flags elf-word) ; Access permission flags.
135     (p-alignment elf-size))) ; Alignment in memory and file.
136    
137     (defconstant +elf-magic+
138     (make-array 4 :element-type '(unsigned-byte 8)
139     :initial-contents '(127 69 76 70))) ; 0x7f-E-L-F
140     (defun elf-p (h)
141     "Make sure the header starts with the ELF magic value."
142     (dotimes (i 4 t)
143     (unless (= (alien:deref h i) (aref +elf-magic+ i))
144     (return nil))))
145    
146     (defun elf-brand (h)
147     "Return the `brand' in the padding of the ELF file."
148     (let ((return (make-string 8 :initial-element #\space)))
149     (dotimes (i 8 return)
150     (let ((code (alien:deref h (+ i 8))))
151     (unless (= code 0)
152     (setf (aref return i) (code-char code)))))))
153    
154     (defun elf-executable-p (n)
155     "Given a file type number, determine if the file is executable."
156     (= n et-executable))
157    
158     (defun load-object-file (name)
159     ;; NAME designates a tempory file created by ld via "load-foreign.csh".
160     ;; Its contents are in a form suitable for stuffing into memory for
161     ;; execution. This function extracts the location and size of the
162     ;; relevant bits and reads them into memory.
163    
164     #|| library:load-foreign.csh
165     #!/bin/csh -fx
166     ld -N -R $argv[1] -Ttext $argv[2] -o $argv[3] $argv[5-]
167     if ($status != 0) exit 1
168    
169     nm -gp $argv[3] > $argv[4]
170     if ($status != 0) exit 2
171     exit 0
172     ||#
173    
174     (format t ";;; Loading object file...~%")
175     (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
176     (unless fd
177     (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
178     (unwind-protect
179     (alien:with-alien ((header eheader))
180     (unix:unix-read fd
181     (alien:alien-sap header)
182     (alien:alien-size eheader :bytes))
183     (unless (elf-p (alien:slot header 'elf-ident))
184     (error (format nil "~A is not an ELF file." name)))
185    
186     (let ((brand (elf-brand (alien:slot header 'elf-ident))))
187     (unless (string= brand "FreeBSD" :end1 6 :end2 6)
188     (error (format nil "~A is not a FreeBSD executable. Brand: ~A"
189     name brand))))
190    
191     (unless (elf-executable-p (alien:slot header 'elf-type))
192     (error (format nil "~A is not executable." name)))
193    
194     (alien:with-alien ((program-header pheader))
195     (unix:unix-read fd
196     (alien:alien-sap program-header)
197     (alien:alien-size pheader :bytes))
198     (let* ((addr (system::allocate-space-in-foreign-segment
199     (alien:slot program-header 'p-memory-size))))
200     (unix:unix-lseek
201     fd (alien:slot program-header 'p-offset) unix:l_set)
202     (unix:unix-read
203     fd addr (alien:slot program-header 'p-file-size)))))
204     (unix:unix-close fd))))
205    
206     (defun parse-symbol-table (name)
207     "Parse symbol table file created by load-foreign script. Modified
208     to skip undefined symbols which don't have an address."
209     (format t ";;; Parsing symbol table...~%")
210     (let ((symbol-table (make-hash-table :test #'equal)))
211     (with-open-file (file name)
212     (loop
213     (let ((line (read-line file nil nil)))
214     (unless line
215     (return))
216     (unless (eql (aref line 0) #\space) ; Skip undefined symbols....
217     (let* ((symbol (subseq line 11))
218     (address (parse-integer line :end 8 :radix 16))
219     #+FreeBSD (kind (aref line 9)) ; filter out .o file names
220     (old-address (gethash symbol lisp::*foreign-symbols*)))
221     (unless (or (null old-address) (= address old-address)
222     #+FreeBSD (char= kind #\F))
223     (warn "~S moved from #x~8,'0X to #x~8,'0X.~%"
224     symbol old-address address))
225     (setf (gethash symbol symbol-table) address))))))
226     (setf lisp::*foreign-symbols* symbol-table)))
227     )
228    
229    
230 ram 1.21 ;;; pw-- This seems to work for FreeBSD. The MAGIC field is not tested
231     ;;; for correct file format so it may croak if ld fails to produce the
232     ;;; expected results. It is probably good enough for now.
233 pw 1.30 #+(or (and FreeBSD (not ELF)) (and sparc (not svr4)))
234 wlott 1.3 (defun load-object-file (name)
235     (format t ";;; Loading object file...~%")
236 wlott 1.8 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
237 wlott 1.3 (unless fd
238 wlott 1.8 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
239 wlott 1.3 (unwind-protect
240 wlott 1.8 (alien:with-alien ((header exec))
241     (unix:unix-read fd
242     (alien:alien-sap header)
243     (alien:alien-size exec :bytes))
244 wlott 1.3 (let* ((len-of-text-and-data
245 wlott 1.8 (+ (alien:slot header 'text) (alien:slot header 'data)))
246 wlott 1.3 (memory-needed
247 wlott 1.8 (+ len-of-text-and-data (alien:slot header 'bss)))
248 wlott 1.3 (addr (allocate-space-in-foreign-segment memory-needed)))
249 wlott 1.8 (unix:unix-read fd addr len-of-text-and-data)))
250     (unix:unix-close fd))))
251 ram 1.1
252 pw 1.30
253 wlott 1.3 #+pmax
254 wlott 1.8 (alien:def-alien-type filehdr
255     (alien:struct nil
256     (magic c-call:unsigned-short)
257     (nscns c-call:unsigned-short)
258     (timdat c-call:long)
259     (symptr c-call:long)
260     (nsyms c-call:long)
261     (opthdr c-call:unsigned-short)
262     (flags c-call:unsigned-short)))
263 ram 1.1
264 wlott 1.3 #+pmax
265 wlott 1.8 (alien:def-alien-type aouthdr
266     (alien:struct nil
267     (magic c-call:short)
268     (vstamp c-call:short)
269     (tsize c-call:long)
270     (dsize c-call:long)
271     (bsize c-call:long)
272     (entry c-call:long)
273     (text_start c-call:long)
274     (data_start c-call:long)))
275 ram 1.1
276 wlott 1.3 #+pmax
277     (defconstant filhsz 20)
278     #+pmax
279     (defconstant aouthsz 56)
280     #+pmax
281     (defconstant scnhsz 40)
282 ram 1.1
283 wlott 1.3 #+pmax
284     (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 ((filehdr filehdr)
291     (aouthdr aouthdr))
292     (unix:unix-read fd
293     (alien:alien-sap filehdr)
294     (alien:alien-size filehdr :bytes))
295     (unix:unix-read fd
296     (alien:alien-sap aouthdr)
297     (alien:alien-size aouthdr :bytes))
298     (let* ((len-of-text-and-data
299     (+ (alien:slot aouthdr 'tsize) (alien:slot aouthdr 'dsize)))
300     (memory-needed
301     (+ len-of-text-and-data (alien:slot aouthdr 'bsize)))
302     (addr (allocate-space-in-foreign-segment memory-needed))
303     (pad-size-1 (if (< (alien:slot aouthdr 'vstamp) 23) 7 15)))
304     (unix:unix-lseek fd
305     (logandc2 (+ filhsz aouthsz
306     (* scnhsz
307     (alien:slot filehdr 'nscns))
308     pad-size-1)
309     pad-size-1)
310     unix:l_set)
311     (unix:unix-read fd addr len-of-text-and-data)))
312 ram 1.16 (unix:unix-close fd))))
313    
314     #+hppa
315     (alien:def-alien-type nil
316     (alien:struct sys_clock
317     (secs c-call:unsigned-int)
318     (nanosecs c-call:unsigned-int)))
319     #+hppa
320     (alien:def-alien-type nil
321     (alien:struct header
322     (system_id c-call:short)
323     (a_magic c-call:short)
324     (version_id c-call:unsigned-int)
325     (file_time (alien:struct sys_clock))
326     (entry_space c-call:unsigned-int)
327     (entry_subspace c-call:unsigned-int)
328     (entry_offset c-call:unsigned-int)
329     (aux_header_location c-call:unsigned-int)
330     (aux_header_size c-call:unsigned-int)
331     (som_length c-call:unsigned-int)
332     (presumed_dp c-call:unsigned-int)
333     (space_location c-call:unsigned-int)
334     (space_total c-call:unsigned-int)
335     (subspace_location c-call:unsigned-int)
336     (subspace_total c-call:unsigned-int)
337     (loader_fixup_location c-call:unsigned-int)
338     (loader_fixup_total c-call:unsigned-int)
339     (space_strings_location c-call:unsigned-int)
340     (space_strings_size c-call:unsigned-int)
341     (init_array_location c-call:unsigned-int)
342     (init_array_total c-call:unsigned-int)
343     (compiler_location c-call:unsigned-int)
344     (compiler_total c-call:unsigned-int)
345     (symbol_location c-call:unsigned-int)
346     (symbol_total c-call:unsigned-int)
347     (fixup_request_location c-call:unsigned-int)
348     (fixup_request_total c-call:unsigned-int)
349     (symbol_strings_location c-call:unsigned-int)
350     (symbol_strings_size c-call:unsigned-int)
351     (unloadable_sp_location c-call:unsigned-int)
352     (unloadable_sp_size c-call:unsigned-int)
353     (checksum c-call:unsigned-int)))
354    
355     #+hppa
356     (alien:def-alien-type nil
357     (alien:struct aux_id
358     #|
359     (mandatory c-call:unsigned-int 1)
360     (copy c-call:unsigned-int 1)
361     (append c-call:unsigned-int 1)
362     (ignore c-call:unsigned-int 1)
363     (reserved c-call:unsigned-int 12)
364     (type c-call:unsigned-int 16)
365     |#
366     (dummy c-call:unsigned-int)
367     (length c-call:unsigned-int)))
368     #+hppa
369     (alien:def-alien-type nil
370     (alien:struct som_exec_auxhdr
371     (som_auxhdr (alien:struct aux_id))
372     (exec_tsize c-call:long)
373     (exec_tmem c-call:long)
374     (exec_tfile c-call:long)
375     (exec_dsize c-call:long)
376     (exec_dmem c-call:long)
377     (exec_dfile c-call:long)
378     (exec_bsize c-call:long)
379     (exec_entry c-call:long)
380     (exec_flags c-call:long)
381     (exec_bfill c-call:long)))
382    
383     #+hppa
384     (alien:def-alien-routine ("bzero" unix-bzero) c-call:void
385     (s alien:system-area-pointer)
386     (n c-call:unsigned-long))
387    
388     #+hppa
389 ram 1.19 (defconstant reloc-magic #x106)
390     #+hppa
391 pw 1.24 (defconstant cpu-pa-risc1-0 #x20b)
392     #+hppa
393 ram 1.19 (defconstant cpu-pa-risc1-1 #x210)
394 pw 1.24 #+hppa
395     (defconstant cpu-pa-risc-max #x2ff)
396 ram 1.19
397     #+hppa
398 ram 1.16 (defun load-object-file (name)
399     (format t ";;; Loading object file...~%")
400     (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
401     (unless fd
402     (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
403     (unwind-protect
404     (alien:with-alien ((header (alien:struct som_exec_auxhdr)))
405     (unix:unix-lseek fd (alien:alien-size (alien:struct header) :bytes)
406     unix:l_set)
407     (unix:unix-read fd
408     (alien:alien-sap header)
409     (alien:alien-size (alien:struct som_exec_auxhdr)
410     :bytes))
411     (let* ((tmem (alien:slot header 'exec_tmem))
412     (tsize (alien:slot header 'exec_tsize))
413     (dmem (alien:slot header 'exec_dmem))
414     (dsize (alien:slot header 'exec_dsize))
415     (bsize (alien:slot header 'exec_bsize))
416     (memory-needed (+ tsize dsize bsize (* 2 4096)))
417     (addr (allocate-space-in-foreign-segment memory-needed)))
418     (unix-bzero addr memory-needed) ;force valid
419     (unix:unix-lseek fd (alien:slot header 'exec_tfile) unix:l_set)
420     (unix:unix-read fd (system:int-sap tmem) tsize)
421     (unix:unix-lseek fd (alien:slot header 'exec_dfile) unix:l_set)
422     (unix:unix-read fd (system:int-sap dmem) dsize)
423     (unix-bzero (system:int-sap (+ dmem dsize)) bsize)
424     ;;(format t "tmem ~X tsize ~X dmem ~X dsize ~X bsize ~X~%"
425     ;; tmem tsize dmem dsize bsize)
426     ;;(format t "tfile ~X dfile ~X~%"
427     ;; (alien:slot header 'exec_tfile)
428     ;; (alien:slot header 'exec_dfile))
429     (alien:alien-funcall (alien:extern-alien
430     "sanctify_for_execution"
431     (alien:function c-call:void
432     alien:system-area-pointer
433     c-call:unsigned-long))
434     addr (+ (- dmem tmem) dsize bsize))
435     ))
436 wlott 1.8 (unix:unix-close fd))))
437 ram 1.1
438 pw 1.30 #-(or linux solaris irix (and FreeBSD elf))
439 wlott 1.3 (defun parse-symbol-table (name)
440     (format t ";;; Parsing symbol table...~%")
441     (let ((symbol-table (make-hash-table :test #'equal)))
442     (with-open-file (file name)
443     (loop
444     (let ((line (read-line file nil nil)))
445     (unless line
446     (return))
447     (let* ((symbol (subseq line 11))
448     (address (parse-integer line :end 8 :radix 16))
449 ram 1.21 #+FreeBSD (kind (aref line 9)) ; filter out .o file names
450 wlott 1.3 (old-address (gethash symbol lisp::*foreign-symbols*)))
451 ram 1.21 (unless (or (null old-address) (= address old-address)
452     #+FreeBSD (char= kind #\F))
453 wlott 1.3 (warn "~S moved from #x~8,'0X to #x~8,'0X.~%"
454     symbol old-address address))
455     (setf (gethash symbol symbol-table) address)))))
456     (setf lisp::*foreign-symbols* symbol-table)))
457 ram 1.1
458 dtc 1.22 #-(or linux irix solaris)
459 ram 1.11 (defun load-foreign (files &key
460 ram 1.1 (libraries '("-lc"))
461 ram 1.12 (base-file
462 ram 1.19 #-hpux
463 ram 1.12 (merge-pathnames *command-line-utility-name*
464 ram 1.19 "path:")
465 wlott 1.20 #+hpux "library:cmucl.orig")
466 wlott 1.3 (env ext:*environment-list*))
467 ram 1.11 "Load-foreign loads a list of C object files into a running Lisp. The files
468     argument should be a single file or a list of files. The files may be
469     specified as namestrings or as pathnames. The libraries argument should be a
470     list of library files as would be specified to ld. They will be searched in
471     the order given. The default is just \"-lc\", i.e., the C library. The
472     base-file argument is used to specify a file to use as the starting place for
473     defined symbols. The default is the C start up code for Lisp. The env
474     argument is the Unix environment variable definitions for the invocation of
475     the linker. The default is the environment passed to Lisp."
476 wlott 1.3 (let ((output-file (pick-temporary-file-name))
477     (symbol-table-file (pick-temporary-file-name))
478 ram 1.19 (error-output (make-string-output-stream))
479     (files (if (atom files) (list files) files)))
480 ram 1.7
481 ram 1.11 (format t ";;; Running library:load-foreign.csh...~%")
482 wlott 1.3 (force-output)
483 ram 1.19 #+hpux
484     (dolist (f files)
485     (with-open-file (stream f :element-type '(unsigned-byte 16))
486 pw 1.24 (unless (let ((sysid (read-byte stream)))
487     (or (eql sysid cpu-pa-risc1-0)
488     (and (>= sysid cpu-pa-risc1-1)
489     (<= sysid cpu-pa-risc-max))))
490 ram 1.19 (error "Object file is wrong format, so can't load-foreign:~
491     ~% ~S"
492     f))
493     (unless (eql (read-byte stream) reloc-magic)
494     (error "Object file is not relocatable, so can't load-foreign:~
495     ~% ~S"
496     f))))
497    
498 wlott 1.14 (let ((proc (ext:run-program
499     "library:load-foreign.csh"
500     (list* (or *previous-linked-object-file*
501     (namestring (truename base-file)))
502     (format nil "~X"
503     *foreign-segment-free-pointer*)
504     output-file
505     symbol-table-file
506     (append (mapcar #'(lambda (name)
507 dtc 1.31 (unix-namestring name))
508 ram 1.19 files)
509 wlott 1.14 libraries))
510     :env env
511     :input nil
512     :output error-output
513     :error :output)))
514 wlott 1.3 (unless proc
515 ram 1.11 (error "Could not run library:load-foreign.csh"))
516 wlott 1.3 (unless (zerop (ext:process-exit-code proc))
517     (system:serve-all-events 0)
518 ram 1.11 (error "library:load-foreign.csh failed:~%~A"
519     (get-output-stream-string error-output)))
520 wlott 1.3 (load-object-file output-file)
521     (parse-symbol-table symbol-table-file)
522 wlott 1.8 (unix:unix-unlink symbol-table-file)
523 wlott 1.3 (let ((old-file *previous-linked-object-file*))
524     (setf *previous-linked-object-file* output-file)
525     (when old-file
526 wlott 1.8 (unix:unix-unlink old-file)))))
527 wlott 1.3 (format t ";;; Done.~%"))
528 ram 1.17
529    
530     (export '(alternate-get-global-address))
531    
532 dtc 1.26 #-(or solaris linux irix)
533 ram 1.21 (defun alternate-get-global-address (symbol)
534     (declare (type simple-string symbol)
535     (ignore symbol))
536     0)
537 ram 1.17
538 pw 1.24 #+(or linux solaris irix)
539 ram 1.17 (progn
540    
541 dtc 1.28 (defconstant rtld-lazy 1
542     "Lazy function call binding")
543     (defconstant rtld-now 2
544     "Immediate function call binding")
545     #+(and linux glibc2)
546     (defconstant rtld-binding-mask #x3
547     "Mask of binding time value")
548    
549     (defconstant rtld-global #-irix #x100 #+irix 4
550     "If set the symbols of the loaded object and its dependencies are
551     made visible as if the object were linked directly into the program")
552 dtc 1.27
553     (defvar *global-table* nil)
554     ;;; Dynamically loaded stuff isn't there upon restoring from a
555     ;;; save--this is primarily for irix, which resolves tzname at
556     ;;; runtime, resulting in *global-table* being set in the saved core
557     ;;; image, resulting in havoc upon restart.
558 pw 1.25 (pushnew #'(lambda () (setq *global-table* nil))
559 dtc 1.27 ext:*after-save-initializations*)
560    
561 pw 1.24 (defvar *dso-linker*
562     #+solaris "/usr/ccs/bin/ld"
563     #+(or linux irix) "/usr/bin/ld")
564 ram 1.17
565     (alien:def-alien-routine dlopen system-area-pointer
566 dtc 1.28 (file c-call:c-string) (mode c-call:int))
567 ram 1.17 (alien:def-alien-routine dlsym system-area-pointer
568     (lib system-area-pointer)
569 dtc 1.28 (name c-call:c-string))
570 ram 1.17 (alien:def-alien-routine dlclose void (lib system-area-pointer))
571     (alien:def-alien-routine dlerror c-call:c-string)
572    
573 dtc 1.27 ;;; Ensure we've opened our own binary so can resolve global variables
574     ;;; in the lisp image that come from libraries. This used to happen
575     ;;; only in alternate-get-global-address, and only if no libraries
576     ;;; were dlopened already, but that didn't work if something was
577     ;;; dlopened before any problem global vars were used. So now we do
578     ;;; this in any function that can add to the global-table, as well as
579     ;;; in alternate-get-global-address.
580 pw 1.25 (defun ensure-lisp-table-opened ()
581     (unless *global-table*
582     ;; Prevent recursive call if dlopen isn't defined
583     (setf *global-table* (int-sap 0))
584     (setf *global-table* (list (dlopen nil rtld-lazy)))
585     (when (zerop (system:sap-int (car *global-table*)))
586     (error "Can't open global symbol table: ~S" (dlerror)))))
587    
588 ram 1.17 (defun load-object-file (file)
589 pw 1.25 (ensure-lisp-table-opened)
590 ram 1.17 ; rtld global: so it can find all the symbols previously loaded
591     ; rtld now: that way dlopen will fail if not all symbols are defined.
592     (let ((sap (dlopen file (logior rtld-now rtld-global))))
593     (if (zerop (sap-int sap))
594     (error "Can't open object ~S: ~S" file (dlerror))
595 pw 1.24 (pushnew sap *global-table* :test #'sap=))))
596 ram 1.17
597     (defun alternate-get-global-address (symbol)
598 pw 1.25 (ensure-lisp-table-opened)
599 ram 1.17 ;; find the symbol in any of the loaded obbjects,
600     ;; search in reverse order of loading, later loadings
601     ;; take precedence
602     (let ((result 0))
603     (do ((table *global-table* (cdr table)))
604     ((or (null (car table)) (not (zerop result))))
605     (setq result (sap-int (dlsym (car table) symbol))))
606     (values result)))
607    
608     (defun load-foreign (files &key
609     (libraries '("-lc"))
610     (base-file nil)
611     (env ext:*environment-list*))
612     "Load-foreign loads a list of C object files into a running Lisp. The files
613     argument should be a single file or a list of files. The files may be
614     specified as namestrings or as pathnames. The libraries argument should be a
615     list of library files as would be specified to ld. They will be searched in
616     the order given. The default is just \"-lc\", i.e., the C library. The
617     base-file argument is used to specify a file to use as the starting place for
618     defined symbols. The default is the C start up code for Lisp. The env
619     argument is the Unix environment variable definitions for the invocation of
620     the linker. The default is the environment passed to Lisp."
621     ;; Note: dlopen remembers the name of an object, when dlopenin
622     ;; the same name twice, the old objects is reused.
623     (declare (ignore base-file))
624     (let ((output-file (pick-temporary-file-name
625 pw 1.23 (concatenate 'string "/tmp/~D~C" (string (gensym)))))
626 ram 1.17 (error-output (make-string-output-stream)))
627 pw 1.24
628     (format t ";;; Running ~A...~%" *dso-linker*)
629 ram 1.17 (force-output)
630     (let ((proc (ext:run-program
631 pw 1.24 *dso-linker*
632 ram 1.17 (list*
633 pw 1.24 #+(or solaris linux) "-G" #+irix "-shared"
634 ram 1.17 "-o"
635     output-file
636     (append (mapcar #'(lambda (name)
637 dtc 1.31 (unix-namestring name))
638 ram 1.17 (if (atom files)
639     (list files)
640     files))
641     libraries))
642     :env env
643     :input nil
644     :output error-output
645     :error :output)))
646     (unless proc
647 pw 1.24 (error "Could not run ~A" *dso-linker*))
648 ram 1.17 (unless (zerop (ext:process-exit-code proc))
649     (system:serve-all-events 0)
650 pw 1.24 (error "~A failed:~%~A" *dso-linker*
651 ram 1.17 (get-output-stream-string error-output)))
652     (load-object-file output-file)
653     (unix:unix-unlink output-file)
654     ))
655     (format t ";;; Done.~%"))
656     )

  ViewVC Help
Powered by ViewVC 1.1.5