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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.20 - (show annotations)
Thu Feb 16 22:41:02 1995 UTC (19 years, 2 months ago) by wlott
Branch: MAIN
Changes since 1.19: +2 -2 lines
Use cmucl.orig, not lisp.orig, on hp-ux.
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.20 1995/02/16 22:41:02 wlott 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 (defvar *previous-linked-object-file* nil)
29 (defvar *foreign-segment-free-pointer* foreign-segment-start)
30
31 (defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C"))
32 (let ((code (char-code #\A)))
33 (loop
34 (let ((name (format nil base (unix:unix-getpid) (code-char code))))
35 (multiple-value-bind
36 (fd errno)
37 (unix:unix-open name
38 (logior unix:o_wronly unix:o_creat unix:o_excl)
39 #o666)
40 (cond ((not (null fd))
41 (unix:unix-close fd)
42 (return name))
43 ((not (= errno unix:eexist))
44 (error "Could not create temporary file ~S: ~A"
45 name (unix:get-unix-error-msg errno)))
46
47 ((= code (char-code #\Z))
48 (setf code (char-code #\a)))
49 ((= code (char-code #\z))
50 (return nil))
51 (t
52 (incf code))))))))
53
54 #+(and sparc (not svr4))
55 (alien:def-alien-type exec
56 (alien:struct nil
57 (magic c-call:unsigned-long)
58 (text c-call:unsigned-long)
59 (data c-call:unsigned-long)
60 (bss c-call:unsigned-long)
61 (syms c-call:unsigned-long)
62 (entry c-call:unsigned-long)
63 (trsize c-call:unsigned-long)
64 (drsize c-call:unsigned-long)))
65
66 #-svr4
67 (defun allocate-space-in-foreign-segment (bytes)
68 (let* ((pagesize-1 (1- (get-page-size)))
69 (memory-needed (logandc2 (+ bytes pagesize-1) pagesize-1))
70 (addr (int-sap *foreign-segment-free-pointer*))
71 (new-ptr (+ *foreign-segment-free-pointer* memory-needed)))
72 (when (> new-ptr (+ foreign-segment-start foreign-segment-size))
73 (error "Not enough memory left."))
74 (setf *foreign-segment-free-pointer* new-ptr)
75 (allocate-system-memory-at addr memory-needed)
76 addr))
77
78 #+(and sparc (not svr4))
79 (defun load-object-file (name)
80 (format t ";;; Loading object file...~%")
81 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
82 (unless fd
83 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
84 (unwind-protect
85 (alien:with-alien ((header exec))
86 (unix:unix-read fd
87 (alien:alien-sap header)
88 (alien:alien-size exec :bytes))
89 (let* ((len-of-text-and-data
90 (+ (alien:slot header 'text) (alien:slot header 'data)))
91 (memory-needed
92 (+ len-of-text-and-data (alien:slot header 'bss)))
93 (addr (allocate-space-in-foreign-segment memory-needed)))
94 (unix:unix-read fd addr len-of-text-and-data)))
95 (unix:unix-close fd))))
96
97 #+pmax
98 (alien:def-alien-type filehdr
99 (alien:struct nil
100 (magic c-call:unsigned-short)
101 (nscns c-call:unsigned-short)
102 (timdat c-call:long)
103 (symptr c-call:long)
104 (nsyms c-call:long)
105 (opthdr c-call:unsigned-short)
106 (flags c-call:unsigned-short)))
107
108 #+pmax
109 (alien:def-alien-type aouthdr
110 (alien:struct nil
111 (magic c-call:short)
112 (vstamp c-call:short)
113 (tsize c-call:long)
114 (dsize c-call:long)
115 (bsize c-call:long)
116 (entry c-call:long)
117 (text_start c-call:long)
118 (data_start c-call:long)))
119
120 #+pmax
121 (defconstant filhsz 20)
122 #+pmax
123 (defconstant aouthsz 56)
124 #+pmax
125 (defconstant scnhsz 40)
126
127 #+pmax
128 (defun load-object-file (name)
129 (format t ";;; Loading object file...~%")
130 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
131 (unless fd
132 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
133 (unwind-protect
134 (alien:with-alien ((filehdr filehdr)
135 (aouthdr aouthdr))
136 (unix:unix-read fd
137 (alien:alien-sap filehdr)
138 (alien:alien-size filehdr :bytes))
139 (unix:unix-read fd
140 (alien:alien-sap aouthdr)
141 (alien:alien-size aouthdr :bytes))
142 (let* ((len-of-text-and-data
143 (+ (alien:slot aouthdr 'tsize) (alien:slot aouthdr 'dsize)))
144 (memory-needed
145 (+ len-of-text-and-data (alien:slot aouthdr 'bsize)))
146 (addr (allocate-space-in-foreign-segment memory-needed))
147 (pad-size-1 (if (< (alien:slot aouthdr 'vstamp) 23) 7 15)))
148 (unix:unix-lseek fd
149 (logandc2 (+ filhsz aouthsz
150 (* scnhsz
151 (alien:slot filehdr 'nscns))
152 pad-size-1)
153 pad-size-1)
154 unix:l_set)
155 (unix:unix-read fd addr len-of-text-and-data)))
156 (unix:unix-close fd))))
157
158 #+hppa
159 (alien:def-alien-type nil
160 (alien:struct sys_clock
161 (secs c-call:unsigned-int)
162 (nanosecs c-call:unsigned-int)))
163 #+hppa
164 (alien:def-alien-type nil
165 (alien:struct header
166 (system_id c-call:short)
167 (a_magic c-call:short)
168 (version_id c-call:unsigned-int)
169 (file_time (alien:struct sys_clock))
170 (entry_space c-call:unsigned-int)
171 (entry_subspace c-call:unsigned-int)
172 (entry_offset c-call:unsigned-int)
173 (aux_header_location c-call:unsigned-int)
174 (aux_header_size c-call:unsigned-int)
175 (som_length c-call:unsigned-int)
176 (presumed_dp c-call:unsigned-int)
177 (space_location c-call:unsigned-int)
178 (space_total c-call:unsigned-int)
179 (subspace_location c-call:unsigned-int)
180 (subspace_total c-call:unsigned-int)
181 (loader_fixup_location c-call:unsigned-int)
182 (loader_fixup_total c-call:unsigned-int)
183 (space_strings_location c-call:unsigned-int)
184 (space_strings_size c-call:unsigned-int)
185 (init_array_location c-call:unsigned-int)
186 (init_array_total c-call:unsigned-int)
187 (compiler_location c-call:unsigned-int)
188 (compiler_total c-call:unsigned-int)
189 (symbol_location c-call:unsigned-int)
190 (symbol_total c-call:unsigned-int)
191 (fixup_request_location c-call:unsigned-int)
192 (fixup_request_total c-call:unsigned-int)
193 (symbol_strings_location c-call:unsigned-int)
194 (symbol_strings_size c-call:unsigned-int)
195 (unloadable_sp_location c-call:unsigned-int)
196 (unloadable_sp_size c-call:unsigned-int)
197 (checksum c-call:unsigned-int)))
198
199 #+hppa
200 (alien:def-alien-type nil
201 (alien:struct aux_id
202 #|
203 (mandatory c-call:unsigned-int 1)
204 (copy c-call:unsigned-int 1)
205 (append c-call:unsigned-int 1)
206 (ignore c-call:unsigned-int 1)
207 (reserved c-call:unsigned-int 12)
208 (type c-call:unsigned-int 16)
209 |#
210 (dummy c-call:unsigned-int)
211 (length c-call:unsigned-int)))
212 #+hppa
213 (alien:def-alien-type nil
214 (alien:struct som_exec_auxhdr
215 (som_auxhdr (alien:struct aux_id))
216 (exec_tsize c-call:long)
217 (exec_tmem c-call:long)
218 (exec_tfile c-call:long)
219 (exec_dsize c-call:long)
220 (exec_dmem c-call:long)
221 (exec_dfile c-call:long)
222 (exec_bsize c-call:long)
223 (exec_entry c-call:long)
224 (exec_flags c-call:long)
225 (exec_bfill c-call:long)))
226
227 #+hppa
228 (alien:def-alien-routine ("bzero" unix-bzero) c-call:void
229 (s alien:system-area-pointer)
230 (n c-call:unsigned-long))
231
232 #+hppa
233 (defconstant reloc-magic #x106)
234 #+hppa
235 (defconstant cpu-pa-risc1-1 #x210)
236
237 #+hppa
238 (defun load-object-file (name)
239 (format t ";;; Loading object file...~%")
240 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
241 (unless fd
242 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
243 (unwind-protect
244 (alien:with-alien ((header (alien:struct som_exec_auxhdr)))
245 (unix:unix-lseek fd (alien:alien-size (alien:struct header) :bytes)
246 unix:l_set)
247 (unix:unix-read fd
248 (alien:alien-sap header)
249 (alien:alien-size (alien:struct som_exec_auxhdr)
250 :bytes))
251 (let* ((tmem (alien:slot header 'exec_tmem))
252 (tsize (alien:slot header 'exec_tsize))
253 (dmem (alien:slot header 'exec_dmem))
254 (dsize (alien:slot header 'exec_dsize))
255 (bsize (alien:slot header 'exec_bsize))
256 (memory-needed (+ tsize dsize bsize (* 2 4096)))
257 (addr (allocate-space-in-foreign-segment memory-needed)))
258 (unix-bzero addr memory-needed) ;force valid
259 (unix:unix-lseek fd (alien:slot header 'exec_tfile) unix:l_set)
260 (unix:unix-read fd (system:int-sap tmem) tsize)
261 (unix:unix-lseek fd (alien:slot header 'exec_dfile) unix:l_set)
262 (unix:unix-read fd (system:int-sap dmem) dsize)
263 (unix-bzero (system:int-sap (+ dmem dsize)) bsize)
264 ;;(format t "tmem ~X tsize ~X dmem ~X dsize ~X bsize ~X~%"
265 ;; tmem tsize dmem dsize bsize)
266 ;;(format t "tfile ~X dfile ~X~%"
267 ;; (alien:slot header 'exec_tfile)
268 ;; (alien:slot header 'exec_dfile))
269 (alien:alien-funcall (alien:extern-alien
270 "sanctify_for_execution"
271 (alien:function c-call:void
272 alien:system-area-pointer
273 c-call:unsigned-long))
274 addr (+ (- dmem tmem) dsize bsize))
275 ))
276 (unix:unix-close fd))))
277
278 #-solaris
279 (defun parse-symbol-table (name)
280 (format t ";;; Parsing symbol table...~%")
281 (let ((symbol-table (make-hash-table :test #'equal)))
282 (with-open-file (file name)
283 (loop
284 (let ((line (read-line file nil nil)))
285 (unless line
286 (return))
287 (let* ((symbol (subseq line 11))
288 (address (parse-integer line :end 8 :radix 16))
289 (old-address (gethash symbol lisp::*foreign-symbols*)))
290 (unless (or (null old-address) (= address old-address))
291 (warn "~S moved from #x~8,'0X to #x~8,'0X.~%"
292 symbol old-address address))
293 (setf (gethash symbol symbol-table) address)))))
294 (setf lisp::*foreign-symbols* symbol-table)))
295
296 #-solaris
297 (defun load-foreign (files &key
298 (libraries '("-lc"))
299 (base-file
300 #-hpux
301 (merge-pathnames *command-line-utility-name*
302 "path:")
303 #+hpux "library:cmucl.orig")
304 (env ext:*environment-list*))
305 "Load-foreign loads a list of C object files into a running Lisp. The files
306 argument should be a single file or a list of files. The files may be
307 specified as namestrings or as pathnames. The libraries argument should be a
308 list of library files as would be specified to ld. They will be searched in
309 the order given. The default is just \"-lc\", i.e., the C library. The
310 base-file argument is used to specify a file to use as the starting place for
311 defined symbols. The default is the C start up code for Lisp. The env
312 argument is the Unix environment variable definitions for the invocation of
313 the linker. The default is the environment passed to Lisp."
314 (let ((output-file (pick-temporary-file-name))
315 (symbol-table-file (pick-temporary-file-name))
316 (error-output (make-string-output-stream))
317 (files (if (atom files) (list files) files)))
318
319 (format t ";;; Running library:load-foreign.csh...~%")
320 (force-output)
321 #+hpux
322 (dolist (f files)
323 (with-open-file (stream f :element-type '(unsigned-byte 16))
324 (unless (eql (read-byte stream) cpu-pa-risc1-1)
325 (error "Object file is wrong format, so can't load-foreign:~
326 ~% ~S"
327 f))
328 (unless (eql (read-byte stream) reloc-magic)
329 (error "Object file is not relocatable, so can't load-foreign:~
330 ~% ~S"
331 f))))
332
333 (let ((proc (ext:run-program
334 "library:load-foreign.csh"
335 (list* (or *previous-linked-object-file*
336 (namestring (truename base-file)))
337 (format nil "~X"
338 *foreign-segment-free-pointer*)
339 output-file
340 symbol-table-file
341 (append (mapcar #'(lambda (name)
342 (unix-namestring name nil))
343 files)
344 libraries))
345 :env env
346 :input nil
347 :output error-output
348 :error :output)))
349 (unless proc
350 (error "Could not run library:load-foreign.csh"))
351 (unless (zerop (ext:process-exit-code proc))
352 (system:serve-all-events 0)
353 (error "library:load-foreign.csh failed:~%~A"
354 (get-output-stream-string error-output)))
355 (load-object-file output-file)
356 (parse-symbol-table symbol-table-file)
357 (unix:unix-unlink symbol-table-file)
358 (let ((old-file *previous-linked-object-file*))
359 (setf *previous-linked-object-file* output-file)
360 (when old-file
361 (unix:unix-unlink old-file)))))
362 (format t ";;; Done.~%"))
363
364
365 (export '(alternate-get-global-address))
366
367 #-solaris
368 (defun alternate-get-global-address (symbol) 0)
369
370 #+solaris
371 (progn
372
373 (defconstant rtld-lazy 1)
374 (defconstant rtld-now 2)
375 (defconstant rtld-global #o400)
376 (defvar *global-table* NIL)
377
378 (alien:def-alien-routine dlopen system-area-pointer
379 (str c-call:c-string) (i c-call:int))
380 (alien:def-alien-routine dlsym system-area-pointer
381 (lib system-area-pointer)
382 (str c-call:c-string))
383 (alien:def-alien-routine dlclose void (lib system-area-pointer))
384 (alien:def-alien-routine dlerror c-call:c-string)
385
386 (defun load-object-file (file)
387 ; rtld global: so it can find all the symbols previously loaded
388 ; rtld now: that way dlopen will fail if not all symbols are defined.
389 (let ((sap (dlopen file (logior rtld-now rtld-global))))
390 (if (zerop (sap-int sap))
391 (error "Can't open object ~S: ~S" file (dlerror))
392 (pushnew sap *global-table*))))
393
394 (defun alternate-get-global-address (symbol)
395 (unless *global-table*
396 ;; Prevent recursive call when dlopen isn't defined.
397 (setq *global-table* (int-sap 0))
398 ;; Load standard object
399 (setq *global-table* (list (dlopen nil rtld-lazy)))
400 (if (zerop (system:sap-int (car *global-table*)))
401 (error "Can't open global symbol table: ~S" (dlerror))))
402 ;; find the symbol in any of the loaded obbjects,
403 ;; search in reverse order of loading, later loadings
404 ;; take precedence
405 (let ((result 0))
406 (do ((table *global-table* (cdr table)))
407 ((or (null (car table)) (not (zerop result))))
408 (setq result (sap-int (dlsym (car table) symbol))))
409 (values result)))
410
411 (defun load-foreign (files &key
412 (libraries '("-lc"))
413 (base-file nil)
414 (env ext:*environment-list*))
415 "Load-foreign loads a list of C object files into a running Lisp. The files
416 argument should be a single file or a list of files. The files may be
417 specified as namestrings or as pathnames. The libraries argument should be a
418 list of library files as would be specified to ld. They will be searched in
419 the order given. The default is just \"-lc\", i.e., the C library. The
420 base-file argument is used to specify a file to use as the starting place for
421 defined symbols. The default is the C start up code for Lisp. The env
422 argument is the Unix environment variable definitions for the invocation of
423 the linker. The default is the environment passed to Lisp."
424 ;; Note: dlopen remembers the name of an object, when dlopenin
425 ;; the same name twice, the old objects is reused.
426 (declare (ignore base-file))
427 (let ((output-file (pick-temporary-file-name
428 (concatenate 'string "/tmp/~D~S" (string (gensym)))))
429 (error-output (make-string-output-stream)))
430
431 (format t ";;; Running /usr/ccs/bin/ld...~%")
432 (force-output)
433 (let ((proc (ext:run-program
434 "/usr/ccs/bin/ld"
435 (list*
436 "-G"
437 "-o"
438 output-file
439 (append (mapcar #'(lambda (name)
440 (unix-namestring name nil))
441 (if (atom files)
442 (list files)
443 files))
444 libraries))
445 :env env
446 :input nil
447 :output error-output
448 :error :output)))
449 (unless proc
450 (error "Could not run /usr/ccs/bin/ld"))
451 (unless (zerop (ext:process-exit-code proc))
452 (system:serve-all-events 0)
453 (error "/usr/ccs/bin/ld failed:~%~A"
454 (get-output-stream-string error-output)))
455 (load-object-file output-file)
456 (unix:unix-unlink output-file)
457 ))
458 (format t ";;; Done.~%"))
459 )

  ViewVC Help
Powered by ViewVC 1.1.5