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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.33 - (show annotations)
Mon May 14 14:22:53 2001 UTC (12 years, 11 months ago) by toy
Branch: MAIN
Changes since 1.32: +19 -10 lines
Add :verbose option to load-foreign to honor *load-verbose*.  (From
Stig Erik Sandoe)
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.33 2001/05/14 14:22:53 toy 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 (verbose *load-verbose*))
468 "Load-foreign loads a list of C object files into a running Lisp. The files
469 argument should be a single file or a list of files. The files may be
470 specified as namestrings or as pathnames. The libraries argument should be a
471 list of library files as would be specified to ld. They will be searched in
472 the order given. The default is just \"-lc\", i.e., the C library. The
473 base-file argument is used to specify a file to use as the starting place for
474 defined symbols. The default is the C start up code for Lisp. The env
475 argument is the Unix environment variable definitions for the invocation of
476 the linker. The default is the environment passed to Lisp."
477 (let ((output-file (pick-temporary-file-name))
478 (symbol-table-file (pick-temporary-file-name))
479 (error-output (make-string-output-stream))
480 (files (if (atom files) (list files) files)))
481
482 (when verbose
483 (format t ";;; Running library:load-foreign.csh...~%")
484 (force-output))
485 #+hpux
486 (dolist (f files)
487 (with-open-file (stream f :element-type '(unsigned-byte 16))
488 (unless (let ((sysid (read-byte stream)))
489 (or (eql sysid cpu-pa-risc1-0)
490 (and (>= sysid cpu-pa-risc1-1)
491 (<= sysid cpu-pa-risc-max))))
492 (error "Object file is wrong format, so can't load-foreign:~
493 ~% ~S"
494 f))
495 (unless (eql (read-byte stream) reloc-magic)
496 (error "Object file is not relocatable, so can't load-foreign:~
497 ~% ~S"
498 f))))
499
500 (let ((proc (ext:run-program
501 "library:load-foreign.csh"
502 (list* (or *previous-linked-object-file*
503 (namestring (truename base-file)))
504 (format nil "~X"
505 *foreign-segment-free-pointer*)
506 output-file
507 symbol-table-file
508 (append (mapcar
509 #'(lambda (name)
510 (or (unix-namestring name)
511 (error 'simple-file-error
512 :pathname name
513 :format-control
514 "File does not exist: ~A."
515 :format-arguments
516 (list name))))
517
518 files)
519 libraries))
520 :env env
521 :input nil
522 :output error-output
523 :error :output)))
524 (unless proc
525 (error "Could not run library:load-foreign.csh"))
526 (unless (zerop (ext:process-exit-code proc))
527 (system:serve-all-events 0)
528 (error "library:load-foreign.csh failed:~%~A"
529 (get-output-stream-string error-output)))
530 (load-object-file output-file)
531 (parse-symbol-table symbol-table-file)
532 (unix:unix-unlink symbol-table-file)
533 (let ((old-file *previous-linked-object-file*))
534 (setf *previous-linked-object-file* output-file)
535 (when old-file
536 (unix:unix-unlink old-file)))))
537 (when verbose
538 (format t ";;; Done.~%")
539 (force-output)))
540
541
542 (export '(alternate-get-global-address))
543
544 #-(or solaris linux irix)
545 (defun alternate-get-global-address (symbol)
546 (declare (type simple-string symbol)
547 (ignore symbol))
548 0)
549
550 #+(or linux solaris irix)
551 (progn
552
553 (defconstant rtld-lazy 1
554 "Lazy function call binding")
555 (defconstant rtld-now 2
556 "Immediate function call binding")
557 #+(and linux glibc2)
558 (defconstant rtld-binding-mask #x3
559 "Mask of binding time value")
560
561 (defconstant rtld-global #-irix #x100 #+irix 4
562 "If set the symbols of the loaded object and its dependencies are
563 made visible as if the object were linked directly into the program")
564
565 (defvar *global-table* nil)
566 ;;; Dynamically loaded stuff isn't there upon restoring from a
567 ;;; save--this is primarily for irix, which resolves tzname at
568 ;;; runtime, resulting in *global-table* being set in the saved core
569 ;;; image, resulting in havoc upon restart.
570 (pushnew #'(lambda () (setq *global-table* nil))
571 ext:*after-save-initializations*)
572
573 (defvar *dso-linker*
574 #+solaris "/usr/ccs/bin/ld"
575 #+(or linux irix) "/usr/bin/ld")
576
577 (alien:def-alien-routine dlopen system-area-pointer
578 (file c-call:c-string) (mode c-call:int))
579 (alien:def-alien-routine dlsym system-area-pointer
580 (lib system-area-pointer)
581 (name c-call:c-string))
582 (alien:def-alien-routine dlclose void (lib system-area-pointer))
583 (alien:def-alien-routine dlerror c-call:c-string)
584
585 ;;; Ensure we've opened our own binary so can resolve global variables
586 ;;; in the lisp image that come from libraries. This used to happen
587 ;;; only in alternate-get-global-address, and only if no libraries
588 ;;; were dlopened already, but that didn't work if something was
589 ;;; dlopened before any problem global vars were used. So now we do
590 ;;; this in any function that can add to the global-table, as well as
591 ;;; in alternate-get-global-address.
592 (defun ensure-lisp-table-opened ()
593 (unless *global-table*
594 ;; Prevent recursive call if dlopen isn't defined
595 (setf *global-table* (int-sap 0))
596 (setf *global-table* (list (dlopen nil rtld-lazy)))
597 (when (zerop (system:sap-int (car *global-table*)))
598 (error "Can't open global symbol table: ~S" (dlerror)))))
599
600 (defun load-object-file (file)
601 (ensure-lisp-table-opened)
602 ; rtld global: so it can find all the symbols previously loaded
603 ; rtld now: that way dlopen will fail if not all symbols are defined.
604 (let ((sap (dlopen file (logior rtld-now rtld-global))))
605 (if (zerop (sap-int sap))
606 (error "Can't open object ~S: ~S" file (dlerror))
607 (pushnew sap *global-table* :test #'sap=))))
608
609 (defun alternate-get-global-address (symbol)
610 (ensure-lisp-table-opened)
611 ;; find the symbol in any of the loaded obbjects,
612 ;; search in reverse order of loading, later loadings
613 ;; take precedence
614 (let ((result 0))
615 (do ((table *global-table* (cdr table)))
616 ((or (null (car table)) (not (zerop result))))
617 (setq result (sap-int (dlsym (car table) symbol))))
618 (values result)))
619
620 (defun load-foreign (files &key
621 (libraries '("-lc"))
622 (base-file nil)
623 (env ext:*environment-list*)
624 (verbose *load-verbose*))
625 "Load-foreign loads a list of C object files into a running Lisp. The files
626 argument should be a single file or a list of files. The files may be
627 specified as namestrings or as pathnames. The libraries argument should be a
628 list of library files as would be specified to ld. They will be searched in
629 the order given. The default is just \"-lc\", i.e., the C library. The
630 base-file argument is used to specify a file to use as the starting place for
631 defined symbols. The default is the C start up code for Lisp. The env
632 argument is the Unix environment variable definitions for the invocation of
633 the linker. The default is the environment passed to Lisp."
634 ;; Note: dlopen remembers the name of an object, when dlopenin
635 ;; the same name twice, the old objects is reused.
636 (declare (ignore base-file))
637 (let ((output-file (pick-temporary-file-name
638 (concatenate 'string "/tmp/~D~C" (string (gensym)))))
639 (error-output (make-string-output-stream)))
640
641 (when verbose
642 (format t ";;; Running ~A...~%" *dso-linker*)
643 (force-output))
644
645 (let ((proc (ext:run-program
646 *dso-linker*
647 (list*
648 #+(or solaris linux) "-G" #+irix "-shared"
649 "-o"
650 output-file
651 (append (mapcar
652 #'(lambda (name)
653 (or (unix-namestring name)
654 (error 'simple-file-error
655 :pathname name
656 :format-control
657 "File does not exist: ~A."
658 :format-arguments
659 (list name))))
660 (if (atom files)
661 (list files)
662 files))
663 libraries))
664 :env env
665 :input nil
666 :output error-output
667 :error :output)))
668 (unless proc
669 (error "Could not run ~A" *dso-linker*))
670 (unless (zerop (ext:process-exit-code proc))
671 (system:serve-all-events 0)
672 (error "~A failed:~%~A" *dso-linker*
673 (get-output-stream-string error-output)))
674 (load-object-file output-file)
675 (unix:unix-unlink output-file)
676 ))
677 (when verbose
678 (format t ";;; Done.~%")
679 (force-output)))
680 )

  ViewVC Help
Powered by ViewVC 1.1.5