/[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.4 - (show annotations)
Wed Sep 27 11:10:20 2000 UTC (13 years, 6 months ago) by dtc
Branch: RELENG_18
CVS Tags: RELEASE_18c
Changes since 1.22.2.3: +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 ;;; -*- Package: SYSTEM -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; 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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/foreign.lisp,v 1.22.2.4 2000/09/27 11:10:20 dtc Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 (in-package "SYSTEM")
13
14 (in-package "ALIEN")
15 (export '(load-foreign))
16 (in-package "SYSTEM")
17 (import 'alien:load-foreign)
18
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
25 #+hppa (defconstant foreign-segment-start #x10C00000)
26 #+hppa (defconstant foreign-segment-size #x00400000)
27
28 #+(and freebsd x86)
29 (defconstant foreign-segment-start #x0E000000)
30 #+(and freebsd x86)
31 (defconstant foreign-segment-size #x02000000)
32
33 (defvar *previous-linked-object-file* nil)
34 #-(or linux irix)
35 (defvar *foreign-segment-free-pointer* foreign-segment-start)
36
37 (defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C"))
38 (let ((code (char-code #\A)))
39 (loop
40 (let ((name (format nil base (unix:unix-getpid) (code-char code))))
41 (multiple-value-bind
42 (fd errno)
43 (unix:unix-open name
44 (logior unix:o_wronly unix:o_creat unix:o_excl)
45 #o666)
46 (cond ((not (null fd))
47 (unix:unix-close fd)
48 (return name))
49 ((not (= errno unix:eexist))
50 (error "Could not create temporary file ~S: ~A"
51 name (unix:get-unix-error-msg errno)))
52
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
60 #+(or (and FreeBSD (not elf)) (and sparc (not svr4)))
61 (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
72 #-(or linux svr4)
73 (defun allocate-space-in-foreign-segment (bytes)
74 (let* ((pagesize-1 (1- (get-page-size)))
75 (memory-needed (logandc2 (+ bytes pagesize-1) pagesize-1))
76 (addr (int-sap *foreign-segment-free-pointer*))
77 (new-ptr (+ *foreign-segment-free-pointer* memory-needed)))
78 (when (> new-ptr (+ foreign-segment-start foreign-segment-size))
79 (error "Not enough memory left."))
80 (setf *foreign-segment-free-pointer* new-ptr)
81 (allocate-system-memory-at addr memory-needed)
82 addr))
83
84
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 ;;; 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 #+(or (and FreeBSD (not ELF)) (and sparc (not svr4)))
234 (defun load-object-file (name)
235 (format t ";;; Loading object file...~%")
236 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
237 (unless fd
238 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
239 (unwind-protect
240 (alien:with-alien ((header exec))
241 (unix:unix-read fd
242 (alien:alien-sap header)
243 (alien:alien-size exec :bytes))
244 (let* ((len-of-text-and-data
245 (+ (alien:slot header 'text) (alien:slot header 'data)))
246 (memory-needed
247 (+ len-of-text-and-data (alien:slot header 'bss)))
248 (addr (allocate-space-in-foreign-segment memory-needed)))
249 (unix:unix-read fd addr len-of-text-and-data)))
250 (unix:unix-close fd))))
251
252
253 #+pmax
254 (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
264 #+pmax
265 (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
276 #+pmax
277 (defconstant filhsz 20)
278 #+pmax
279 (defconstant aouthsz 56)
280 #+pmax
281 (defconstant scnhsz 40)
282
283 #+pmax
284 (defun load-object-file (name)
285 (format t ";;; Loading object file...~%")
286 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
287 (unless fd
288 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
289 (unwind-protect
290 (alien:with-alien ((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 (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 (defconstant reloc-magic #x106)
390 #+hppa
391 (defconstant cpu-pa-risc1-0 #x20b)
392 #+hppa
393 (defconstant cpu-pa-risc1-1 #x210)
394 #+hppa
395 (defconstant cpu-pa-risc-max #x2ff)
396
397 #+hppa
398 (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 (unix:unix-close fd))))
437
438 #-(or linux solaris irix (and FreeBSD elf))
439 (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 #+FreeBSD (kind (aref line 9)) ; filter out .o file names
450 (old-address (gethash symbol lisp::*foreign-symbols*)))
451 (unless (or (null old-address) (= address old-address)
452 #+FreeBSD (char= kind #\F))
453 (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
458 #-(or linux irix solaris)
459 (defun load-foreign (files &key
460 (libraries '("-lc"))
461 (base-file
462 #-hpux
463 (merge-pathnames *command-line-utility-name*
464 "path:")
465 #+hpux "library:cmucl.orig")
466 (env ext:*environment-list*))
467 "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 (let ((output-file (pick-temporary-file-name))
477 (symbol-table-file (pick-temporary-file-name))
478 (error-output (make-string-output-stream))
479 (files (if (atom files) (list files) files)))
480
481 (format t ";;; Running library:load-foreign.csh...~%")
482 (force-output)
483 #+hpux
484 (dolist (f files)
485 (with-open-file (stream f :element-type '(unsigned-byte 16))
486 (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 (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 (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 (unix-namestring name))
508 files)
509 libraries))
510 :env env
511 :input nil
512 :output error-output
513 :error :output)))
514 (unless proc
515 (error "Could not run library:load-foreign.csh"))
516 (unless (zerop (ext:process-exit-code proc))
517 (system:serve-all-events 0)
518 (error "library:load-foreign.csh failed:~%~A"
519 (get-output-stream-string error-output)))
520 (load-object-file output-file)
521 (parse-symbol-table symbol-table-file)
522 (unix:unix-unlink symbol-table-file)
523 (let ((old-file *previous-linked-object-file*))
524 (setf *previous-linked-object-file* output-file)
525 (when old-file
526 (unix:unix-unlink old-file)))))
527 (format t ";;; Done.~%"))
528
529
530 (export '(alternate-get-global-address))
531
532 #-(or solaris linux irix)
533 (defun alternate-get-global-address (symbol)
534 (declare (type simple-string symbol)
535 (ignore symbol))
536 0)
537
538 #+(or linux solaris irix)
539 (progn
540
541 (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
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 (pushnew #'(lambda () (setq *global-table* nil))
559 ext:*after-save-initializations*)
560
561 (defvar *dso-linker*
562 #+solaris "/usr/ccs/bin/ld"
563 #+(or linux irix) "/usr/bin/ld")
564
565 (alien:def-alien-routine dlopen system-area-pointer
566 (file c-call:c-string) (mode c-call:int))
567 (alien:def-alien-routine dlsym system-area-pointer
568 (lib system-area-pointer)
569 (name c-call:c-string))
570 (alien:def-alien-routine dlclose void (lib system-area-pointer))
571 (alien:def-alien-routine dlerror c-call:c-string)
572
573 ;;; 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 (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 (defun load-object-file (file)
589 (ensure-lisp-table-opened)
590 ; 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 (pushnew sap *global-table* :test #'sap=))))
596
597 (defun alternate-get-global-address (symbol)
598 (ensure-lisp-table-opened)
599 ;; 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 (concatenate 'string "/tmp/~D~C" (string (gensym)))))
626 (error-output (make-string-output-stream)))
627
628 (format t ";;; Running ~A...~%" *dso-linker*)
629 (force-output)
630 (let ((proc (ext:run-program
631 *dso-linker*
632 (list*
633 #+(or solaris linux) "-G" #+irix "-shared"
634 "-o"
635 output-file
636 (append (mapcar #'(lambda (name)
637 (unix-namestring name))
638 (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 (error "Could not run ~A" *dso-linker*))
648 (unless (zerop (ext:process-exit-code proc))
649 (system:serve-all-events 0)
650 (error "~A failed:~%~A" *dso-linker*
651 (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