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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5