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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.25 - (show annotations)
Sat Oct 25 16:31:55 1997 UTC (16 years, 5 months ago) by pw
Branch: MAIN
Changes since 1.24: +23 -8 lines
From: Timothy Miller <tsm@cs.brown.edu>

Ok, here are the updated patches to make the same cmucl lisp.core work
across OS versions under irix, still by making tzname resolved at runtime
(on irix only).
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.25 1997/10/25 16:31:55 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 freebsd 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 (defconstant rtld-now 2)
396 (defconstant rtld-global #-irix #o400 #+irix 4)
397 ;; Dynamically loaded stuff isn't there upon restoring from a save--this is
398 ;;primarily for irix, which resolves tzname at runtime, resulting in
399 ;;*global-table* being set in the saved core image, resulting in havoc upon
400 ;;restart.
401 (pushnew #'(lambda () (setq *global-table* nil))
402 ext:*after-save-initializations*)
403 (defvar *global-table* NIL)
404 (defvar *dso-linker*
405 #+solaris "/usr/ccs/bin/ld"
406 #+(or linux irix) "/usr/bin/ld")
407
408 (alien:def-alien-routine dlopen system-area-pointer
409 (str c-call:c-string) (i c-call:int))
410 (alien:def-alien-routine dlsym system-area-pointer
411 (lib system-area-pointer)
412 (str c-call:c-string))
413 (alien:def-alien-routine dlclose void (lib system-area-pointer))
414 (alien:def-alien-routine dlerror c-call:c-string)
415
416 ;; Ensure we've opened our own binary so can resolve global variables in the
417 ;;lisp image that come from libraries. This used to happen only in
418 ;;alternate-get-global-address, and only if no libraries were dlopened already,
419 ;;but that didn't work if something was dlopened before any problem global vars
420 ;;were used. So now we do this in any function that can add to the global-table,
421 ;;as well as in a-g-g-a.
422 (defun ensure-lisp-table-opened ()
423 (unless *global-table*
424 ;; Prevent recursive call if dlopen isn't defined
425 (setf *global-table* (int-sap 0))
426 (setf *global-table* (list (dlopen nil rtld-lazy)))
427 (when (zerop (system:sap-int (car *global-table*)))
428 (error "Can't open global symbol table: ~S" (dlerror)))))
429
430 (defun load-object-file (file)
431 (ensure-lisp-table-opened)
432 ; rtld global: so it can find all the symbols previously loaded
433 ; rtld now: that way dlopen will fail if not all symbols are defined.
434 (let ((sap (dlopen file (logior rtld-now rtld-global))))
435 (if (zerop (sap-int sap))
436 (error "Can't open object ~S: ~S" file (dlerror))
437 (pushnew sap *global-table* :test #'sap=))))
438
439 (defun alternate-get-global-address (symbol)
440 (ensure-lisp-table-opened)
441 ;; find the symbol in any of the loaded obbjects,
442 ;; search in reverse order of loading, later loadings
443 ;; take precedence
444 (let ((result 0))
445 (do ((table *global-table* (cdr table)))
446 ((or (null (car table)) (not (zerop result))))
447 (setq result (sap-int (dlsym (car table) symbol))))
448 (values result)))
449
450 (defun load-foreign (files &key
451 (libraries '("-lc"))
452 (base-file nil)
453 (env ext:*environment-list*))
454 "Load-foreign loads a list of C object files into a running Lisp. The files
455 argument should be a single file or a list of files. The files may be
456 specified as namestrings or as pathnames. The libraries argument should be a
457 list of library files as would be specified to ld. They will be searched in
458 the order given. The default is just \"-lc\", i.e., the C library. The
459 base-file argument is used to specify a file to use as the starting place for
460 defined symbols. The default is the C start up code for Lisp. The env
461 argument is the Unix environment variable definitions for the invocation of
462 the linker. The default is the environment passed to Lisp."
463 ;; Note: dlopen remembers the name of an object, when dlopenin
464 ;; the same name twice, the old objects is reused.
465 (declare (ignore base-file))
466 (let ((output-file (pick-temporary-file-name
467 (concatenate 'string "/tmp/~D~C" (string (gensym)))))
468 (error-output (make-string-output-stream)))
469
470 (format t ";;; Running ~A...~%" *dso-linker*)
471 (force-output)
472 (let ((proc (ext:run-program
473 *dso-linker*
474 (list*
475 #+(or solaris linux) "-G" #+irix "-shared"
476 "-o"
477 output-file
478 (append (mapcar #'(lambda (name)
479 (unix-namestring name nil))
480 (if (atom files)
481 (list files)
482 files))
483 libraries))
484 :env env
485 :input nil
486 :output error-output
487 :error :output)))
488 (unless proc
489 (error "Could not run ~A" *dso-linker*))
490 (unless (zerop (ext:process-exit-code proc))
491 (system:serve-all-events 0)
492 (error "~A failed:~%~A" *dso-linker*
493 (get-output-stream-string error-output)))
494 (load-object-file output-file)
495 (unix:unix-unlink output-file)
496 ))
497 (format t ";;; Done.~%"))
498 )

  ViewVC Help
Powered by ViewVC 1.1.5