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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.20 - (hide 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 wlott 1.3 ;;; -*- Package: SYSTEM -*-
2     ;;;
3 ram 1.1 ;;; **********************************************************************
4 ram 1.5 ;;; 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 wlott 1.20 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/foreign.lisp,v 1.20 1995/02/16 22:41:02 wlott Exp $")
9 ram 1.5 ;;;
10 ram 1.1 ;;; **********************************************************************
11 wlott 1.3 ;;;
12     (in-package "SYSTEM")
13 ram 1.1
14 ram 1.11 (in-package "ALIEN")
15 wlott 1.3 (export '(load-foreign))
16 wlott 1.4 (in-package "SYSTEM")
17 ram 1.11 (import 'alien:load-foreign)
18 wlott 1.13
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 wlott 1.4
25 ram 1.16 #+hppa (defconstant foreign-segment-start #x10C00000)
26     #+hppa (defconstant foreign-segment-size #x00400000)
27    
28 wlott 1.3 (defvar *previous-linked-object-file* nil)
29     (defvar *foreign-segment-free-pointer* foreign-segment-start)
30 ram 1.1
31 wlott 1.3 (defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C"))
32     (let ((code (char-code #\A)))
33     (loop
34 wlott 1.8 (let ((name (format nil base (unix:unix-getpid) (code-char code))))
35 wlott 1.3 (multiple-value-bind
36     (fd errno)
37 wlott 1.8 (unix:unix-open name
38     (logior unix:o_wronly unix:o_creat unix:o_excl)
39 wlott 1.3 #o666)
40     (cond ((not (null fd))
41 wlott 1.8 (unix:unix-close fd)
42 wlott 1.3 (return name))
43 wlott 1.8 ((not (= errno unix:eexist))
44 wlott 1.3 (error "Could not create temporary file ~S: ~A"
45 wlott 1.8 name (unix:get-unix-error-msg errno)))
46 wlott 1.3
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 ram 1.1
54 ram 1.17 #+(and sparc (not svr4))
55 wlott 1.8 (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 ram 1.1
66 ram 1.17 #-svr4
67 wlott 1.3 (defun allocate-space-in-foreign-segment (bytes)
68 ram 1.6 (let* ((pagesize-1 (1- (get-page-size)))
69 wlott 1.3 (memory-needed (logandc2 (+ bytes pagesize-1) pagesize-1))
70     (addr (int-sap *foreign-segment-free-pointer*))
71 ram 1.15 (new-ptr (+ *foreign-segment-free-pointer* memory-needed)))
72 wlott 1.3 (when (> new-ptr (+ foreign-segment-start foreign-segment-size))
73     (error "Not enough memory left."))
74     (setf *foreign-segment-free-pointer* new-ptr)
75 wlott 1.10 (allocate-system-memory-at addr memory-needed)
76 wlott 1.3 addr))
77 ram 1.1
78 ram 1.17 #+(and sparc (not svr4))
79 wlott 1.3 (defun load-object-file (name)
80     (format t ";;; Loading object file...~%")
81 wlott 1.8 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
82 wlott 1.3 (unless fd
83 wlott 1.8 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
84 wlott 1.3 (unwind-protect
85 wlott 1.8 (alien:with-alien ((header exec))
86     (unix:unix-read fd
87     (alien:alien-sap header)
88     (alien:alien-size exec :bytes))
89 wlott 1.3 (let* ((len-of-text-and-data
90 wlott 1.8 (+ (alien:slot header 'text) (alien:slot header 'data)))
91 wlott 1.3 (memory-needed
92 wlott 1.8 (+ len-of-text-and-data (alien:slot header 'bss)))
93 wlott 1.3 (addr (allocate-space-in-foreign-segment memory-needed)))
94 wlott 1.8 (unix:unix-read fd addr len-of-text-and-data)))
95     (unix:unix-close fd))))
96 ram 1.1
97 wlott 1.3 #+pmax
98 wlott 1.8 (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 ram 1.1
108 wlott 1.3 #+pmax
109 wlott 1.8 (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 ram 1.1
120 wlott 1.3 #+pmax
121     (defconstant filhsz 20)
122     #+pmax
123     (defconstant aouthsz 56)
124     #+pmax
125     (defconstant scnhsz 40)
126 ram 1.1
127 wlott 1.3 #+pmax
128     (defun load-object-file (name)
129     (format t ";;; Loading object file...~%")
130 wlott 1.8 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
131 wlott 1.3 (unless fd
132 wlott 1.8 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
133 wlott 1.3 (unwind-protect
134 wlott 1.8 (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 ram 1.16 (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 ram 1.19 (defconstant reloc-magic #x106)
234     #+hppa
235     (defconstant cpu-pa-risc1-1 #x210)
236    
237     #+hppa
238 ram 1.16 (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 wlott 1.8 (unix:unix-close fd))))
277 ram 1.1
278 ram 1.17 #-solaris
279 wlott 1.3 (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 ram 1.1
296 ram 1.17 #-solaris
297 ram 1.11 (defun load-foreign (files &key
298 ram 1.1 (libraries '("-lc"))
299 ram 1.12 (base-file
300 ram 1.19 #-hpux
301 ram 1.12 (merge-pathnames *command-line-utility-name*
302 ram 1.19 "path:")
303 wlott 1.20 #+hpux "library:cmucl.orig")
304 wlott 1.3 (env ext:*environment-list*))
305 ram 1.11 "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 wlott 1.3 (let ((output-file (pick-temporary-file-name))
315     (symbol-table-file (pick-temporary-file-name))
316 ram 1.19 (error-output (make-string-output-stream))
317     (files (if (atom files) (list files) files)))
318 ram 1.7
319 ram 1.11 (format t ";;; Running library:load-foreign.csh...~%")
320 wlott 1.3 (force-output)
321 ram 1.19 #+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 wlott 1.14 (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 ram 1.19 files)
344 wlott 1.14 libraries))
345     :env env
346     :input nil
347     :output error-output
348     :error :output)))
349 wlott 1.3 (unless proc
350 ram 1.11 (error "Could not run library:load-foreign.csh"))
351 wlott 1.3 (unless (zerop (ext:process-exit-code proc))
352     (system:serve-all-events 0)
353 ram 1.11 (error "library:load-foreign.csh failed:~%~A"
354     (get-output-stream-string error-output)))
355 wlott 1.3 (load-object-file output-file)
356     (parse-symbol-table symbol-table-file)
357 wlott 1.8 (unix:unix-unlink symbol-table-file)
358 wlott 1.3 (let ((old-file *previous-linked-object-file*))
359     (setf *previous-linked-object-file* output-file)
360     (when old-file
361 wlott 1.8 (unix:unix-unlink old-file)))))
362 wlott 1.3 (format t ";;; Done.~%"))
363 ram 1.17
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