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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.22 - (show annotations)
Mon May 5 23:13:52 1997 UTC (16 years, 11 months ago) by dtc
Branch: MAIN
Branch point for: RELENG_18
Changes since 1.21: +3 -3 lines
Patches from Simon for the MIPS IRIX port: hacks for foreign functions
which are not yet supported; hack for errno; signed-array support.
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 1997/05/05 23:13:52 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 (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-1 #x210)
245
246 #+hppa
247 (defun load-object-file (name)
248 (format t ";;; Loading object file...~%")
249 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
250 (unless fd
251 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
252 (unwind-protect
253 (alien:with-alien ((header (alien:struct som_exec_auxhdr)))
254 (unix:unix-lseek fd (alien:alien-size (alien:struct header) :bytes)
255 unix:l_set)
256 (unix:unix-read fd
257 (alien:alien-sap header)
258 (alien:alien-size (alien:struct som_exec_auxhdr)
259 :bytes))
260 (let* ((tmem (alien:slot header 'exec_tmem))
261 (tsize (alien:slot header 'exec_tsize))
262 (dmem (alien:slot header 'exec_dmem))
263 (dsize (alien:slot header 'exec_dsize))
264 (bsize (alien:slot header 'exec_bsize))
265 (memory-needed (+ tsize dsize bsize (* 2 4096)))
266 (addr (allocate-space-in-foreign-segment memory-needed)))
267 (unix-bzero addr memory-needed) ;force valid
268 (unix:unix-lseek fd (alien:slot header 'exec_tfile) unix:l_set)
269 (unix:unix-read fd (system:int-sap tmem) tsize)
270 (unix:unix-lseek fd (alien:slot header 'exec_dfile) unix:l_set)
271 (unix:unix-read fd (system:int-sap dmem) dsize)
272 (unix-bzero (system:int-sap (+ dmem dsize)) bsize)
273 ;;(format t "tmem ~X tsize ~X dmem ~X dsize ~X bsize ~X~%"
274 ;; tmem tsize dmem dsize bsize)
275 ;;(format t "tfile ~X dfile ~X~%"
276 ;; (alien:slot header 'exec_tfile)
277 ;; (alien:slot header 'exec_dfile))
278 (alien:alien-funcall (alien:extern-alien
279 "sanctify_for_execution"
280 (alien:function c-call:void
281 alien:system-area-pointer
282 c-call:unsigned-long))
283 addr (+ (- dmem tmem) dsize bsize))
284 ))
285 (unix:unix-close fd))))
286
287 #-(or linux solaris)
288 (defun parse-symbol-table (name)
289 (format t ";;; Parsing symbol table...~%")
290 (let ((symbol-table (make-hash-table :test #'equal)))
291 (with-open-file (file name)
292 (loop
293 (let ((line (read-line file nil nil)))
294 (unless line
295 (return))
296 (let* ((symbol (subseq line 11))
297 (address (parse-integer line :end 8 :radix 16))
298 #+FreeBSD (kind (aref line 9)) ; filter out .o file names
299 (old-address (gethash symbol lisp::*foreign-symbols*)))
300 (unless (or (null old-address) (= address old-address)
301 #+FreeBSD (char= kind #\F))
302 (warn "~S moved from #x~8,'0X to #x~8,'0X.~%"
303 symbol old-address address))
304 (setf (gethash symbol symbol-table) address)))))
305 (setf lisp::*foreign-symbols* symbol-table)))
306
307 #-(or linux irix solaris)
308 (defun load-foreign (files &key
309 (libraries '("-lc"))
310 (base-file
311 #-hpux
312 (merge-pathnames *command-line-utility-name*
313 "path:")
314 #+hpux "library:cmucl.orig")
315 (env ext:*environment-list*))
316 "Load-foreign loads a list of C object files into a running Lisp. The files
317 argument should be a single file or a list of files. The files may be
318 specified as namestrings or as pathnames. The libraries argument should be a
319 list of library files as would be specified to ld. They will be searched in
320 the order given. The default is just \"-lc\", i.e., the C library. The
321 base-file argument is used to specify a file to use as the starting place for
322 defined symbols. The default is the C start up code for Lisp. The env
323 argument is the Unix environment variable definitions for the invocation of
324 the linker. The default is the environment passed to Lisp."
325 (let ((output-file (pick-temporary-file-name))
326 (symbol-table-file (pick-temporary-file-name))
327 (error-output (make-string-output-stream))
328 (files (if (atom files) (list files) files)))
329
330 (format t ";;; Running library:load-foreign.csh...~%")
331 (force-output)
332 #+hpux
333 (dolist (f files)
334 (with-open-file (stream f :element-type '(unsigned-byte 16))
335 (unless (eql (read-byte stream) cpu-pa-risc1-1)
336 (error "Object file is wrong format, so can't load-foreign:~
337 ~% ~S"
338 f))
339 (unless (eql (read-byte stream) reloc-magic)
340 (error "Object file is not relocatable, so can't load-foreign:~
341 ~% ~S"
342 f))))
343
344 (let ((proc (ext:run-program
345 "library:load-foreign.csh"
346 (list* (or *previous-linked-object-file*
347 (namestring (truename base-file)))
348 (format nil "~X"
349 *foreign-segment-free-pointer*)
350 output-file
351 symbol-table-file
352 (append (mapcar #'(lambda (name)
353 (unix-namestring name nil))
354 files)
355 libraries))
356 :env env
357 :input nil
358 :output error-output
359 :error :output)))
360 (unless proc
361 (error "Could not run library:load-foreign.csh"))
362 (unless (zerop (ext:process-exit-code proc))
363 (system:serve-all-events 0)
364 (error "library:load-foreign.csh failed:~%~A"
365 (get-output-stream-string error-output)))
366 (load-object-file output-file)
367 (parse-symbol-table symbol-table-file)
368 (unix:unix-unlink symbol-table-file)
369 (let ((old-file *previous-linked-object-file*))
370 (setf *previous-linked-object-file* output-file)
371 (when old-file
372 (unix:unix-unlink old-file)))))
373 (format t ";;; Done.~%"))
374
375
376 (export '(alternate-get-global-address))
377
378 #-(or freebsd solaris linux)
379 (defun alternate-get-global-address (symbol)
380 (declare (type simple-string symbol)
381 (ignore symbol))
382 0)
383
384 #+(or linux solaris)
385 (progn
386
387 (defconstant rtld-lazy 1)
388 (defconstant rtld-now 2)
389 (defconstant rtld-global #o400)
390 (defvar *global-table* NIL)
391
392 (alien:def-alien-routine dlopen system-area-pointer
393 (str c-call:c-string) (i c-call:int))
394 (alien:def-alien-routine dlsym system-area-pointer
395 (lib system-area-pointer)
396 (str c-call:c-string))
397 (alien:def-alien-routine dlclose void (lib system-area-pointer))
398 (alien:def-alien-routine dlerror c-call:c-string)
399
400 (defun load-object-file (file)
401 ; rtld global: so it can find all the symbols previously loaded
402 ; rtld now: that way dlopen will fail if not all symbols are defined.
403 (let ((sap (dlopen file (logior rtld-now rtld-global))))
404 (if (zerop (sap-int sap))
405 (error "Can't open object ~S: ~S" file (dlerror))
406 (pushnew sap *global-table*))))
407
408 (defun alternate-get-global-address (symbol)
409 (unless *global-table*
410 ;; Prevent recursive call when dlopen isn't defined.
411 (setq *global-table* (int-sap 0))
412 ;; Load standard object
413 (setq *global-table* (list (dlopen nil rtld-lazy)))
414 (if (zerop (system:sap-int (car *global-table*)))
415 (error "Can't open global symbol table: ~S" (dlerror))))
416 ;; find the symbol in any of the loaded obbjects,
417 ;; search in reverse order of loading, later loadings
418 ;; take precedence
419 (let ((result 0))
420 (do ((table *global-table* (cdr table)))
421 ((or (null (car table)) (not (zerop result))))
422 (setq result (sap-int (dlsym (car table) symbol))))
423 (values result)))
424
425 (defun load-foreign (files &key
426 (libraries '("-lc"))
427 (base-file nil)
428 (env ext:*environment-list*))
429 "Load-foreign loads a list of C object files into a running Lisp. The files
430 argument should be a single file or a list of files. The files may be
431 specified as namestrings or as pathnames. The libraries argument should be a
432 list of library files as would be specified to ld. They will be searched in
433 the order given. The default is just \"-lc\", i.e., the C library. The
434 base-file argument is used to specify a file to use as the starting place for
435 defined symbols. The default is the C start up code for Lisp. The env
436 argument is the Unix environment variable definitions for the invocation of
437 the linker. The default is the environment passed to Lisp."
438 ;; Note: dlopen remembers the name of an object, when dlopenin
439 ;; the same name twice, the old objects is reused.
440 (declare (ignore base-file))
441 (let ((output-file (pick-temporary-file-name
442 (concatenate 'string "/tmp/~D~S" (string (gensym)))))
443 (error-output (make-string-output-stream)))
444
445 #-linux (format t ";;; Running /usr/ccs/bin/ld...~%")
446 #+linux (format t ";;; Running /usr/bin/ld...~%")
447 (force-output)
448 (let ((proc (ext:run-program
449 #-linux "/usr/ccs/bin/ld"
450 #+linux "/usr/bin/ld"
451 (list*
452 "-G"
453 "-o"
454 output-file
455 (append (mapcar #'(lambda (name)
456 (unix-namestring name nil))
457 (if (atom files)
458 (list files)
459 files))
460 libraries))
461 :env env
462 :input nil
463 :output error-output
464 :error :output)))
465 (unless proc
466 (error #+linux "Could not run /usr/bin/ld"
467 #-linux "Could not run /usr/ccs/bin/ld"))
468 (unless (zerop (ext:process-exit-code proc))
469 (system:serve-all-events 0)
470 (error #-linux "/usr/ccs/bin/ld failed:~%~A"
471 #+linux "/usr/bin/ld failed:~%~A"
472 (get-output-stream-string error-output)))
473 (load-object-file output-file)
474 (unix:unix-unlink output-file)
475 ))
476 (format t ";;; Done.~%"))
477 )

  ViewVC Help
Powered by ViewVC 1.1.5