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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.22 - (hide 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 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 dtc 1.22 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/foreign.lisp,v 1.22 1997/05/05 23:13:52 dtc 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 ram 1.21 #+(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 wlott 1.3 (defvar *previous-linked-object-file* nil)
34 dtc 1.22 #-(or linux irix)
35 wlott 1.3 (defvar *foreign-segment-free-pointer* foreign-segment-start)
36 ram 1.1
37 wlott 1.3 (defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C"))
38     (let ((code (char-code #\A)))
39     (loop
40 wlott 1.8 (let ((name (format nil base (unix:unix-getpid) (code-char code))))
41 wlott 1.3 (multiple-value-bind
42     (fd errno)
43 wlott 1.8 (unix:unix-open name
44     (logior unix:o_wronly unix:o_creat unix:o_excl)
45 wlott 1.3 #o666)
46     (cond ((not (null fd))
47 wlott 1.8 (unix:unix-close fd)
48 wlott 1.3 (return name))
49 wlott 1.8 ((not (= errno unix:eexist))
50 wlott 1.3 (error "Could not create temporary file ~S: ~A"
51 wlott 1.8 name (unix:get-unix-error-msg errno)))
52 wlott 1.3
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 ram 1.1
60 ram 1.21 #+(or FreeBSD (and sparc (not svr4)))
61 wlott 1.8 (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 ram 1.1
72 ram 1.21 #-(or linux svr4)
73 wlott 1.3 (defun allocate-space-in-foreign-segment (bytes)
74 ram 1.6 (let* ((pagesize-1 (1- (get-page-size)))
75 wlott 1.3 (memory-needed (logandc2 (+ bytes pagesize-1) pagesize-1))
76     (addr (int-sap *foreign-segment-free-pointer*))
77 ram 1.15 (new-ptr (+ *foreign-segment-free-pointer* memory-needed)))
78 wlott 1.3 (when (> new-ptr (+ foreign-segment-start foreign-segment-size))
79     (error "Not enough memory left."))
80     (setf *foreign-segment-free-pointer* new-ptr)
81 wlott 1.10 (allocate-system-memory-at addr memory-needed)
82 wlott 1.3 addr))
83 ram 1.1
84 ram 1.21 ;;; 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 wlott 1.3 (defun load-object-file (name)
89     (format t ";;; Loading object file...~%")
90 wlott 1.8 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
91 wlott 1.3 (unless fd
92 wlott 1.8 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
93 wlott 1.3 (unwind-protect
94 wlott 1.8 (alien:with-alien ((header exec))
95     (unix:unix-read fd
96     (alien:alien-sap header)
97     (alien:alien-size exec :bytes))
98 wlott 1.3 (let* ((len-of-text-and-data
99 wlott 1.8 (+ (alien:slot header 'text) (alien:slot header 'data)))
100 wlott 1.3 (memory-needed
101 wlott 1.8 (+ len-of-text-and-data (alien:slot header 'bss)))
102 wlott 1.3 (addr (allocate-space-in-foreign-segment memory-needed)))
103 wlott 1.8 (unix:unix-read fd addr len-of-text-and-data)))
104     (unix:unix-close fd))))
105 ram 1.1
106 wlott 1.3 #+pmax
107 wlott 1.8 (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 ram 1.1
117 wlott 1.3 #+pmax
118 wlott 1.8 (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 ram 1.1
129 wlott 1.3 #+pmax
130     (defconstant filhsz 20)
131     #+pmax
132     (defconstant aouthsz 56)
133     #+pmax
134     (defconstant scnhsz 40)
135 ram 1.1
136 wlott 1.3 #+pmax
137     (defun load-object-file (name)
138     (format t ";;; Loading object file...~%")
139 wlott 1.8 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
140 wlott 1.3 (unless fd
141 wlott 1.8 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
142 wlott 1.3 (unwind-protect
143 wlott 1.8 (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 ram 1.16 (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 ram 1.19 (defconstant reloc-magic #x106)
243     #+hppa
244     (defconstant cpu-pa-risc1-1 #x210)
245    
246     #+hppa
247 ram 1.16 (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 wlott 1.8 (unix:unix-close fd))))
286 ram 1.1
287 ram 1.21 #-(or linux solaris)
288 wlott 1.3 (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 ram 1.21 #+FreeBSD (kind (aref line 9)) ; filter out .o file names
299 wlott 1.3 (old-address (gethash symbol lisp::*foreign-symbols*)))
300 ram 1.21 (unless (or (null old-address) (= address old-address)
301     #+FreeBSD (char= kind #\F))
302 wlott 1.3 (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 ram 1.1
307 dtc 1.22 #-(or linux irix solaris)
308 ram 1.11 (defun load-foreign (files &key
309 ram 1.1 (libraries '("-lc"))
310 ram 1.12 (base-file
311 ram 1.19 #-hpux
312 ram 1.12 (merge-pathnames *command-line-utility-name*
313 ram 1.19 "path:")
314 wlott 1.20 #+hpux "library:cmucl.orig")
315 wlott 1.3 (env ext:*environment-list*))
316 ram 1.11 "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 wlott 1.3 (let ((output-file (pick-temporary-file-name))
326     (symbol-table-file (pick-temporary-file-name))
327 ram 1.19 (error-output (make-string-output-stream))
328     (files (if (atom files) (list files) files)))
329 ram 1.7
330 ram 1.11 (format t ";;; Running library:load-foreign.csh...~%")
331 wlott 1.3 (force-output)
332 ram 1.19 #+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 wlott 1.14 (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 ram 1.19 files)
355 wlott 1.14 libraries))
356     :env env
357     :input nil
358     :output error-output
359     :error :output)))
360 wlott 1.3 (unless proc
361 ram 1.11 (error "Could not run library:load-foreign.csh"))
362 wlott 1.3 (unless (zerop (ext:process-exit-code proc))
363     (system:serve-all-events 0)
364 ram 1.11 (error "library:load-foreign.csh failed:~%~A"
365     (get-output-stream-string error-output)))
366 wlott 1.3 (load-object-file output-file)
367     (parse-symbol-table symbol-table-file)
368 wlott 1.8 (unix:unix-unlink symbol-table-file)
369 wlott 1.3 (let ((old-file *previous-linked-object-file*))
370     (setf *previous-linked-object-file* output-file)
371     (when old-file
372 wlott 1.8 (unix:unix-unlink old-file)))))
373 wlott 1.3 (format t ";;; Done.~%"))
374 ram 1.17
375    
376     (export '(alternate-get-global-address))
377    
378 ram 1.21 #-(or freebsd solaris linux)
379     (defun alternate-get-global-address (symbol)
380     (declare (type simple-string symbol)
381     (ignore symbol))
382     0)
383 ram 1.17
384 ram 1.21 #+(or linux solaris)
385 ram 1.17 (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 ram 1.21 #-linux (format t ";;; Running /usr/ccs/bin/ld...~%")
446     #+linux (format t ";;; Running /usr/bin/ld...~%")
447 ram 1.17 (force-output)
448     (let ((proc (ext:run-program
449 ram 1.21 #-linux "/usr/ccs/bin/ld"
450     #+linux "/usr/bin/ld"
451 ram 1.17 (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 ram 1.21 (error #+linux "Could not run /usr/bin/ld"
467     #-linux "Could not run /usr/ccs/bin/ld"))
468 ram 1.17 (unless (zerop (ext:process-exit-code proc))
469     (system:serve-all-events 0)
470 ram 1.21 (error #-linux "/usr/ccs/bin/ld failed:~%~A"
471     #+linux "/usr/bin/ld failed:~%~A"
472 ram 1.17 (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