/[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.2 - (show annotations)
Tue Jun 23 11:21:57 1998 UTC (15 years, 9 months ago) by pw
Branch: RELENG_18
CVS Tags: RELEASE_18b
Changes since 1.22.2.1: +61 -29 lines
This (huge) revision brings the RELENG_18 branch up to the current HEAD.
Note code/unix-glib2.lisp not yet included -- not sure it is ready to go.
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.2 1998/06/23 11:21:57 pw 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 (not linux) x86)
29 (defconstant foreign-segment-start #x7000000) ; just an unused space
30 #+(and (not linux) x86)
31 (defconstant foreign-segment-size #x00400000)
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 FreeBSD (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 ;;; pw-- This seems to work for FreeBSD. The MAGIC field is not tested
85 ;;; for correct file format so it may croak if ld fails to produce the
86 ;;; expected results. It is probably good enough for now.
87 #+(or FreeBSD (and sparc (not svr4)))
88 (defun load-object-file (name)
89 (format t ";;; Loading object file...~%")
90 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
91 (unless fd
92 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
93 (unwind-protect
94 (alien:with-alien ((header exec))
95 (unix:unix-read fd
96 (alien:alien-sap header)
97 (alien:alien-size exec :bytes))
98 (let* ((len-of-text-and-data
99 (+ (alien:slot header 'text) (alien:slot header 'data)))
100 (memory-needed
101 (+ len-of-text-and-data (alien:slot header 'bss)))
102 (addr (allocate-space-in-foreign-segment memory-needed)))
103 (unix:unix-read fd addr len-of-text-and-data)))
104 (unix:unix-close fd))))
105
106 #+pmax
107 (alien:def-alien-type filehdr
108 (alien:struct nil
109 (magic c-call:unsigned-short)
110 (nscns c-call:unsigned-short)
111 (timdat c-call:long)
112 (symptr c-call:long)
113 (nsyms c-call:long)
114 (opthdr c-call:unsigned-short)
115 (flags c-call:unsigned-short)))
116
117 #+pmax
118 (alien:def-alien-type aouthdr
119 (alien:struct nil
120 (magic c-call:short)
121 (vstamp c-call:short)
122 (tsize c-call:long)
123 (dsize c-call:long)
124 (bsize c-call:long)
125 (entry c-call:long)
126 (text_start c-call:long)
127 (data_start c-call:long)))
128
129 #+pmax
130 (defconstant filhsz 20)
131 #+pmax
132 (defconstant aouthsz 56)
133 #+pmax
134 (defconstant scnhsz 40)
135
136 #+pmax
137 (defun load-object-file (name)
138 (format t ";;; Loading object file...~%")
139 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
140 (unless fd
141 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
142 (unwind-protect
143 (alien:with-alien ((filehdr filehdr)
144 (aouthdr aouthdr))
145 (unix:unix-read fd
146 (alien:alien-sap filehdr)
147 (alien:alien-size filehdr :bytes))
148 (unix:unix-read fd
149 (alien:alien-sap aouthdr)
150 (alien:alien-size aouthdr :bytes))
151 (let* ((len-of-text-and-data
152 (+ (alien:slot aouthdr 'tsize) (alien:slot aouthdr 'dsize)))
153 (memory-needed
154 (+ len-of-text-and-data (alien:slot aouthdr 'bsize)))
155 (addr (allocate-space-in-foreign-segment memory-needed))
156 (pad-size-1 (if (< (alien:slot aouthdr 'vstamp) 23) 7 15)))
157 (unix:unix-lseek fd
158 (logandc2 (+ filhsz aouthsz
159 (* scnhsz
160 (alien:slot filehdr 'nscns))
161 pad-size-1)
162 pad-size-1)
163 unix:l_set)
164 (unix:unix-read fd addr len-of-text-and-data)))
165 (unix:unix-close fd))))
166
167 #+hppa
168 (alien:def-alien-type nil
169 (alien:struct sys_clock
170 (secs c-call:unsigned-int)
171 (nanosecs c-call:unsigned-int)))
172 #+hppa
173 (alien:def-alien-type nil
174 (alien:struct header
175 (system_id c-call:short)
176 (a_magic c-call:short)
177 (version_id c-call:unsigned-int)
178 (file_time (alien:struct sys_clock))
179 (entry_space c-call:unsigned-int)
180 (entry_subspace c-call:unsigned-int)
181 (entry_offset c-call:unsigned-int)
182 (aux_header_location c-call:unsigned-int)
183 (aux_header_size c-call:unsigned-int)
184 (som_length c-call:unsigned-int)
185 (presumed_dp c-call:unsigned-int)
186 (space_location c-call:unsigned-int)
187 (space_total c-call:unsigned-int)
188 (subspace_location c-call:unsigned-int)
189 (subspace_total c-call:unsigned-int)
190 (loader_fixup_location c-call:unsigned-int)
191 (loader_fixup_total c-call:unsigned-int)
192 (space_strings_location c-call:unsigned-int)
193 (space_strings_size c-call:unsigned-int)
194 (init_array_location c-call:unsigned-int)
195 (init_array_total c-call:unsigned-int)
196 (compiler_location c-call:unsigned-int)
197 (compiler_total c-call:unsigned-int)
198 (symbol_location c-call:unsigned-int)
199 (symbol_total c-call:unsigned-int)
200 (fixup_request_location c-call:unsigned-int)
201 (fixup_request_total c-call:unsigned-int)
202 (symbol_strings_location c-call:unsigned-int)
203 (symbol_strings_size c-call:unsigned-int)
204 (unloadable_sp_location c-call:unsigned-int)
205 (unloadable_sp_size c-call:unsigned-int)
206 (checksum c-call:unsigned-int)))
207
208 #+hppa
209 (alien:def-alien-type nil
210 (alien:struct aux_id
211 #|
212 (mandatory c-call:unsigned-int 1)
213 (copy c-call:unsigned-int 1)
214 (append c-call:unsigned-int 1)
215 (ignore c-call:unsigned-int 1)
216 (reserved c-call:unsigned-int 12)
217 (type c-call:unsigned-int 16)
218 |#
219 (dummy c-call:unsigned-int)
220 (length c-call:unsigned-int)))
221 #+hppa
222 (alien:def-alien-type nil
223 (alien:struct som_exec_auxhdr
224 (som_auxhdr (alien:struct aux_id))
225 (exec_tsize c-call:long)
226 (exec_tmem c-call:long)
227 (exec_tfile c-call:long)
228 (exec_dsize c-call:long)
229 (exec_dmem c-call:long)
230 (exec_dfile c-call:long)
231 (exec_bsize c-call:long)
232 (exec_entry c-call:long)
233 (exec_flags c-call:long)
234 (exec_bfill c-call:long)))
235
236 #+hppa
237 (alien:def-alien-routine ("bzero" unix-bzero) c-call:void
238 (s alien:system-area-pointer)
239 (n c-call:unsigned-long))
240
241 #+hppa
242 (defconstant reloc-magic #x106)
243 #+hppa
244 (defconstant cpu-pa-risc1-0 #x20b)
245 #+hppa
246 (defconstant cpu-pa-risc1-1 #x210)
247 #+hppa
248 (defconstant cpu-pa-risc-max #x2ff)
249
250 #+hppa
251 (defun load-object-file (name)
252 (format t ";;; Loading object file...~%")
253 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
254 (unless fd
255 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
256 (unwind-protect
257 (alien:with-alien ((header (alien:struct som_exec_auxhdr)))
258 (unix:unix-lseek fd (alien:alien-size (alien:struct header) :bytes)
259 unix:l_set)
260 (unix:unix-read fd
261 (alien:alien-sap header)
262 (alien:alien-size (alien:struct som_exec_auxhdr)
263 :bytes))
264 (let* ((tmem (alien:slot header 'exec_tmem))
265 (tsize (alien:slot header 'exec_tsize))
266 (dmem (alien:slot header 'exec_dmem))
267 (dsize (alien:slot header 'exec_dsize))
268 (bsize (alien:slot header 'exec_bsize))
269 (memory-needed (+ tsize dsize bsize (* 2 4096)))
270 (addr (allocate-space-in-foreign-segment memory-needed)))
271 (unix-bzero addr memory-needed) ;force valid
272 (unix:unix-lseek fd (alien:slot header 'exec_tfile) unix:l_set)
273 (unix:unix-read fd (system:int-sap tmem) tsize)
274 (unix:unix-lseek fd (alien:slot header 'exec_dfile) unix:l_set)
275 (unix:unix-read fd (system:int-sap dmem) dsize)
276 (unix-bzero (system:int-sap (+ dmem dsize)) bsize)
277 ;;(format t "tmem ~X tsize ~X dmem ~X dsize ~X bsize ~X~%"
278 ;; tmem tsize dmem dsize bsize)
279 ;;(format t "tfile ~X dfile ~X~%"
280 ;; (alien:slot header 'exec_tfile)
281 ;; (alien:slot header 'exec_dfile))
282 (alien:alien-funcall (alien:extern-alien
283 "sanctify_for_execution"
284 (alien:function c-call:void
285 alien:system-area-pointer
286 c-call:unsigned-long))
287 addr (+ (- dmem tmem) dsize bsize))
288 ))
289 (unix:unix-close fd))))
290
291 #-(or linux solaris irix)
292 (defun parse-symbol-table (name)
293 (format t ";;; Parsing symbol table...~%")
294 (let ((symbol-table (make-hash-table :test #'equal)))
295 (with-open-file (file name)
296 (loop
297 (let ((line (read-line file nil nil)))
298 (unless line
299 (return))
300 (let* ((symbol (subseq line 11))
301 (address (parse-integer line :end 8 :radix 16))
302 #+FreeBSD (kind (aref line 9)) ; filter out .o file names
303 (old-address (gethash symbol lisp::*foreign-symbols*)))
304 (unless (or (null old-address) (= address old-address)
305 #+FreeBSD (char= kind #\F))
306 (warn "~S moved from #x~8,'0X to #x~8,'0X.~%"
307 symbol old-address address))
308 (setf (gethash symbol symbol-table) address)))))
309 (setf lisp::*foreign-symbols* symbol-table)))
310
311 #-(or linux irix solaris)
312 (defun load-foreign (files &key
313 (libraries '("-lc"))
314 (base-file
315 #-hpux
316 (merge-pathnames *command-line-utility-name*
317 "path:")
318 #+hpux "library:cmucl.orig")
319 (env ext:*environment-list*))
320 "Load-foreign loads a list of C object files into a running Lisp. The files
321 argument should be a single file or a list of files. The files may be
322 specified as namestrings or as pathnames. The libraries argument should be a
323 list of library files as would be specified to ld. They will be searched in
324 the order given. The default is just \"-lc\", i.e., the C library. The
325 base-file argument is used to specify a file to use as the starting place for
326 defined symbols. The default is the C start up code for Lisp. The env
327 argument is the Unix environment variable definitions for the invocation of
328 the linker. The default is the environment passed to Lisp."
329 (let ((output-file (pick-temporary-file-name))
330 (symbol-table-file (pick-temporary-file-name))
331 (error-output (make-string-output-stream))
332 (files (if (atom files) (list files) files)))
333
334 (format t ";;; Running library:load-foreign.csh...~%")
335 (force-output)
336 #+hpux
337 (dolist (f files)
338 (with-open-file (stream f :element-type '(unsigned-byte 16))
339 (unless (let ((sysid (read-byte stream)))
340 (or (eql sysid cpu-pa-risc1-0)
341 (and (>= sysid cpu-pa-risc1-1)
342 (<= sysid cpu-pa-risc-max))))
343 (error "Object file is wrong format, so can't load-foreign:~
344 ~% ~S"
345 f))
346 (unless (eql (read-byte stream) reloc-magic)
347 (error "Object file is not relocatable, so can't load-foreign:~
348 ~% ~S"
349 f))))
350
351 (let ((proc (ext:run-program
352 "library:load-foreign.csh"
353 (list* (or *previous-linked-object-file*
354 (namestring (truename base-file)))
355 (format nil "~X"
356 *foreign-segment-free-pointer*)
357 output-file
358 symbol-table-file
359 (append (mapcar #'(lambda (name)
360 (unix-namestring name nil))
361 files)
362 libraries))
363 :env env
364 :input nil
365 :output error-output
366 :error :output)))
367 (unless proc
368 (error "Could not run library:load-foreign.csh"))
369 (unless (zerop (ext:process-exit-code proc))
370 (system:serve-all-events 0)
371 (error "library:load-foreign.csh failed:~%~A"
372 (get-output-stream-string error-output)))
373 (load-object-file output-file)
374 (parse-symbol-table symbol-table-file)
375 (unix:unix-unlink symbol-table-file)
376 (let ((old-file *previous-linked-object-file*))
377 (setf *previous-linked-object-file* output-file)
378 (when old-file
379 (unix:unix-unlink old-file)))))
380 (format t ";;; Done.~%"))
381
382
383 (export '(alternate-get-global-address))
384
385 #-(or solaris linux irix)
386 (defun alternate-get-global-address (symbol)
387 (declare (type simple-string symbol)
388 (ignore symbol))
389 0)
390
391 #+(or linux solaris irix)
392 (progn
393
394 (defconstant rtld-lazy 1
395 "Lazy function call binding")
396 (defconstant rtld-now 2
397 "Immediate function call binding")
398 #+(and linux glibc2)
399 (defconstant rtld-binding-mask #x3
400 "Mask of binding time value")
401
402 (defconstant rtld-global #-irix #x100 #+irix 4
403 "If set the symbols of the loaded object and its dependencies are
404 made visible as if the object were linked directly into the program")
405
406 (defvar *global-table* nil)
407 ;;; Dynamically loaded stuff isn't there upon restoring from a
408 ;;; save--this is primarily for irix, which resolves tzname at
409 ;;; runtime, resulting in *global-table* being set in the saved core
410 ;;; image, resulting in havoc upon restart.
411 (pushnew #'(lambda () (setq *global-table* nil))
412 ext:*after-save-initializations*)
413
414 (defvar *dso-linker*
415 #+solaris "/usr/ccs/bin/ld"
416 #+(or linux irix) "/usr/bin/ld")
417
418 (alien:def-alien-routine dlopen system-area-pointer
419 (file c-call:c-string) (mode c-call:int))
420 (alien:def-alien-routine dlsym system-area-pointer
421 (lib system-area-pointer)
422 (name c-call:c-string))
423 (alien:def-alien-routine dlclose void (lib system-area-pointer))
424 (alien:def-alien-routine dlerror c-call:c-string)
425
426 ;;; Ensure we've opened our own binary so can resolve global variables
427 ;;; in the lisp image that come from libraries. This used to happen
428 ;;; only in alternate-get-global-address, and only if no libraries
429 ;;; were dlopened already, but that didn't work if something was
430 ;;; dlopened before any problem global vars were used. So now we do
431 ;;; this in any function that can add to the global-table, as well as
432 ;;; in alternate-get-global-address.
433 (defun ensure-lisp-table-opened ()
434 (unless *global-table*
435 ;; Prevent recursive call if dlopen isn't defined
436 (setf *global-table* (int-sap 0))
437 (setf *global-table* (list (dlopen nil rtld-lazy)))
438 (when (zerop (system:sap-int (car *global-table*)))
439 (error "Can't open global symbol table: ~S" (dlerror)))))
440
441 (defun load-object-file (file)
442 (ensure-lisp-table-opened)
443 ; rtld global: so it can find all the symbols previously loaded
444 ; rtld now: that way dlopen will fail if not all symbols are defined.
445 (let ((sap (dlopen file (logior rtld-now rtld-global))))
446 (if (zerop (sap-int sap))
447 (error "Can't open object ~S: ~S" file (dlerror))
448 (pushnew sap *global-table* :test #'sap=))))
449
450 (defun alternate-get-global-address (symbol)
451 (ensure-lisp-table-opened)
452 ;; find the symbol in any of the loaded obbjects,
453 ;; search in reverse order of loading, later loadings
454 ;; take precedence
455 (let ((result 0))
456 (do ((table *global-table* (cdr table)))
457 ((or (null (car table)) (not (zerop result))))
458 (setq result (sap-int (dlsym (car table) symbol))))
459 (values result)))
460
461 (defun load-foreign (files &key
462 (libraries '("-lc"))
463 (base-file nil)
464 (env ext:*environment-list*))
465 "Load-foreign loads a list of C object files into a running Lisp. The files
466 argument should be a single file or a list of files. The files may be
467 specified as namestrings or as pathnames. The libraries argument should be a
468 list of library files as would be specified to ld. They will be searched in
469 the order given. The default is just \"-lc\", i.e., the C library. The
470 base-file argument is used to specify a file to use as the starting place for
471 defined symbols. The default is the C start up code for Lisp. The env
472 argument is the Unix environment variable definitions for the invocation of
473 the linker. The default is the environment passed to Lisp."
474 ;; Note: dlopen remembers the name of an object, when dlopenin
475 ;; the same name twice, the old objects is reused.
476 (declare (ignore base-file))
477 (let ((output-file (pick-temporary-file-name
478 (concatenate 'string "/tmp/~D~C" (string (gensym)))))
479 (error-output (make-string-output-stream)))
480
481 (format t ";;; Running ~A...~%" *dso-linker*)
482 (force-output)
483 (let ((proc (ext:run-program
484 *dso-linker*
485 (list*
486 #+(or solaris linux) "-G" #+irix "-shared"
487 "-o"
488 output-file
489 (append (mapcar #'(lambda (name)
490 (unix-namestring name nil))
491 (if (atom files)
492 (list files)
493 files))
494 libraries))
495 :env env
496 :input nil
497 :output error-output
498 :error :output)))
499 (unless proc
500 (error "Could not run ~A" *dso-linker*))
501 (unless (zerop (ext:process-exit-code proc))
502 (system:serve-all-events 0)
503 (error "~A failed:~%~A" *dso-linker*
504 (get-output-stream-string error-output)))
505 (load-object-file output-file)
506 (unix:unix-unlink output-file)
507 ))
508 (format t ";;; Done.~%"))
509 )

  ViewVC Help
Powered by ViewVC 1.1.5