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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.16 - (hide annotations)
Sat Oct 1 00:38:19 1994 UTC (19 years, 6 months ago) by ram
Branch: MAIN
Changes since 1.15: +119 -1 lines
Support for HPPA from TSM.
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     ;;; 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 ram 1.16 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/foreign.lisp,v 1.16 1994/10/01 00:38:19 ram Exp $")
11 ram 1.5 ;;;
12 ram 1.1 ;;; **********************************************************************
13 wlott 1.3 ;;;
14     (in-package "SYSTEM")
15 ram 1.1
16 ram 1.11 (in-package "ALIEN")
17 wlott 1.3 (export '(load-foreign))
18 wlott 1.4 (in-package "SYSTEM")
19 ram 1.11 (import 'alien:load-foreign)
20 wlott 1.13
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 wlott 1.4
27 ram 1.16 #+hppa (defconstant foreign-segment-start #x10C00000)
28     #+hppa (defconstant foreign-segment-size #x00400000)
29    
30 wlott 1.3 (defvar *previous-linked-object-file* nil)
31     (defvar *foreign-segment-free-pointer* foreign-segment-start)
32 ram 1.1
33 wlott 1.3 (defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C"))
34     (let ((code (char-code #\A)))
35     (loop
36 wlott 1.8 (let ((name (format nil base (unix:unix-getpid) (code-char code))))
37 wlott 1.3 (multiple-value-bind
38     (fd errno)
39 wlott 1.8 (unix:unix-open name
40     (logior unix:o_wronly unix:o_creat unix:o_excl)
41 wlott 1.3 #o666)
42     (cond ((not (null fd))
43 wlott 1.8 (unix:unix-close fd)
44 wlott 1.3 (return name))
45 wlott 1.8 ((not (= errno unix:eexist))
46 wlott 1.3 (error "Could not create temporary file ~S: ~A"
47 wlott 1.8 name (unix:get-unix-error-msg errno)))
48 wlott 1.3
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 ram 1.1
56 wlott 1.3 #+sparc
57 wlott 1.8 (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 ram 1.1
68 wlott 1.3 (defun allocate-space-in-foreign-segment (bytes)
69 ram 1.6 (let* ((pagesize-1 (1- (get-page-size)))
70 wlott 1.3 (memory-needed (logandc2 (+ bytes pagesize-1) pagesize-1))
71     (addr (int-sap *foreign-segment-free-pointer*))
72 ram 1.15 (new-ptr (+ *foreign-segment-free-pointer* memory-needed)))
73 wlott 1.3 (when (> new-ptr (+ foreign-segment-start foreign-segment-size))
74     (error "Not enough memory left."))
75     (setf *foreign-segment-free-pointer* new-ptr)
76 wlott 1.10 (allocate-system-memory-at addr memory-needed)
77 wlott 1.3 addr))
78 ram 1.1
79 wlott 1.3 #+sparc
80     (defun load-object-file (name)
81     (format t ";;; Loading object file...~%")
82 wlott 1.8 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
83 wlott 1.3 (unless fd
84 wlott 1.8 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
85 wlott 1.3 (unwind-protect
86 wlott 1.8 (alien:with-alien ((header exec))
87     (unix:unix-read fd
88     (alien:alien-sap header)
89     (alien:alien-size exec :bytes))
90 wlott 1.3 (let* ((len-of-text-and-data
91 wlott 1.8 (+ (alien:slot header 'text) (alien:slot header 'data)))
92 wlott 1.3 (memory-needed
93 wlott 1.8 (+ len-of-text-and-data (alien:slot header 'bss)))
94 wlott 1.3 (addr (allocate-space-in-foreign-segment memory-needed)))
95 wlott 1.8 (unix:unix-read fd addr len-of-text-and-data)))
96     (unix:unix-close fd))))
97 ram 1.1
98 wlott 1.3 #+pmax
99 wlott 1.8 (alien:def-alien-type filehdr
100     (alien:struct nil
101     (magic c-call:unsigned-short)
102     (nscns c-call:unsigned-short)
103     (timdat c-call:long)
104     (symptr c-call:long)
105     (nsyms c-call:long)
106     (opthdr c-call:unsigned-short)
107     (flags c-call:unsigned-short)))
108 ram 1.1
109 wlott 1.3 #+pmax
110 wlott 1.8 (alien:def-alien-type aouthdr
111     (alien:struct nil
112     (magic c-call:short)
113     (vstamp c-call:short)
114     (tsize c-call:long)
115     (dsize c-call:long)
116     (bsize c-call:long)
117     (entry c-call:long)
118     (text_start c-call:long)
119     (data_start c-call:long)))
120 ram 1.1
121 wlott 1.3 #+pmax
122     (defconstant filhsz 20)
123     #+pmax
124     (defconstant aouthsz 56)
125     #+pmax
126     (defconstant scnhsz 40)
127 ram 1.1
128 wlott 1.3 #+pmax
129     (defun load-object-file (name)
130     (format t ";;; Loading object file...~%")
131 wlott 1.8 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
132 wlott 1.3 (unless fd
133 wlott 1.8 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
134 wlott 1.3 (unwind-protect
135 wlott 1.8 (alien:with-alien ((filehdr filehdr)
136     (aouthdr aouthdr))
137     (unix:unix-read fd
138     (alien:alien-sap filehdr)
139     (alien:alien-size filehdr :bytes))
140     (unix:unix-read fd
141     (alien:alien-sap aouthdr)
142     (alien:alien-size aouthdr :bytes))
143     (let* ((len-of-text-and-data
144     (+ (alien:slot aouthdr 'tsize) (alien:slot aouthdr 'dsize)))
145     (memory-needed
146     (+ len-of-text-and-data (alien:slot aouthdr 'bsize)))
147     (addr (allocate-space-in-foreign-segment memory-needed))
148     (pad-size-1 (if (< (alien:slot aouthdr 'vstamp) 23) 7 15)))
149     (unix:unix-lseek fd
150     (logandc2 (+ filhsz aouthsz
151     (* scnhsz
152     (alien:slot filehdr 'nscns))
153     pad-size-1)
154     pad-size-1)
155     unix:l_set)
156     (unix:unix-read fd addr len-of-text-and-data)))
157 ram 1.16 (unix:unix-close fd))))
158    
159     #+hppa
160     (alien:def-alien-type nil
161     (alien:struct sys_clock
162     (secs c-call:unsigned-int)
163     (nanosecs c-call:unsigned-int)))
164     #+hppa
165     (alien:def-alien-type nil
166     (alien:struct header
167     (system_id c-call:short)
168     (a_magic c-call:short)
169     (version_id c-call:unsigned-int)
170     (file_time (alien:struct sys_clock))
171     (entry_space c-call:unsigned-int)
172     (entry_subspace c-call:unsigned-int)
173     (entry_offset c-call:unsigned-int)
174     (aux_header_location c-call:unsigned-int)
175     (aux_header_size c-call:unsigned-int)
176     (som_length c-call:unsigned-int)
177     (presumed_dp c-call:unsigned-int)
178     (space_location c-call:unsigned-int)
179     (space_total c-call:unsigned-int)
180     (subspace_location c-call:unsigned-int)
181     (subspace_total c-call:unsigned-int)
182     (loader_fixup_location c-call:unsigned-int)
183     (loader_fixup_total c-call:unsigned-int)
184     (space_strings_location c-call:unsigned-int)
185     (space_strings_size c-call:unsigned-int)
186     (init_array_location c-call:unsigned-int)
187     (init_array_total c-call:unsigned-int)
188     (compiler_location c-call:unsigned-int)
189     (compiler_total c-call:unsigned-int)
190     (symbol_location c-call:unsigned-int)
191     (symbol_total c-call:unsigned-int)
192     (fixup_request_location c-call:unsigned-int)
193     (fixup_request_total c-call:unsigned-int)
194     (symbol_strings_location c-call:unsigned-int)
195     (symbol_strings_size c-call:unsigned-int)
196     (unloadable_sp_location c-call:unsigned-int)
197     (unloadable_sp_size c-call:unsigned-int)
198     (checksum c-call:unsigned-int)))
199    
200     #+hppa
201     (alien:def-alien-type nil
202     (alien:struct aux_id
203     #|
204     (mandatory c-call:unsigned-int 1)
205     (copy c-call:unsigned-int 1)
206     (append c-call:unsigned-int 1)
207     (ignore c-call:unsigned-int 1)
208     (reserved c-call:unsigned-int 12)
209     (type c-call:unsigned-int 16)
210     |#
211     (dummy c-call:unsigned-int)
212     (length c-call:unsigned-int)))
213     #+hppa
214     (alien:def-alien-type nil
215     (alien:struct som_exec_auxhdr
216     (som_auxhdr (alien:struct aux_id))
217     (exec_tsize c-call:long)
218     (exec_tmem c-call:long)
219     (exec_tfile c-call:long)
220     (exec_dsize c-call:long)
221     (exec_dmem c-call:long)
222     (exec_dfile c-call:long)
223     (exec_bsize c-call:long)
224     (exec_entry c-call:long)
225     (exec_flags c-call:long)
226     (exec_bfill c-call:long)))
227    
228     #+hppa
229     (alien:def-alien-routine ("bzero" unix-bzero) c-call:void
230     (s alien:system-area-pointer)
231     (n c-call:unsigned-long))
232    
233     #+hppa
234     (defun load-object-file (name)
235     (format t ";;; Loading object file...~%")
236     (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
237     (unless fd
238     (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
239     (unwind-protect
240     (alien:with-alien ((header (alien:struct som_exec_auxhdr)))
241     (unix:unix-lseek fd (alien:alien-size (alien:struct header) :bytes)
242     unix:l_set)
243     (unix:unix-read fd
244     (alien:alien-sap header)
245     (alien:alien-size (alien:struct som_exec_auxhdr)
246     :bytes))
247     (let* ((tmem (alien:slot header 'exec_tmem))
248     (tsize (alien:slot header 'exec_tsize))
249     (dmem (alien:slot header 'exec_dmem))
250     (dsize (alien:slot header 'exec_dsize))
251     (bsize (alien:slot header 'exec_bsize))
252     (memory-needed (+ tsize dsize bsize (* 2 4096)))
253     (addr (allocate-space-in-foreign-segment memory-needed)))
254     (unix-bzero addr memory-needed) ;force valid
255     (unix:unix-lseek fd (alien:slot header 'exec_tfile) unix:l_set)
256     (unix:unix-read fd (system:int-sap tmem) tsize)
257     (unix:unix-lseek fd (alien:slot header 'exec_dfile) unix:l_set)
258     (unix:unix-read fd (system:int-sap dmem) dsize)
259     (unix-bzero (system:int-sap (+ dmem dsize)) bsize)
260     ;;(format t "tmem ~X tsize ~X dmem ~X dsize ~X bsize ~X~%"
261     ;; tmem tsize dmem dsize bsize)
262     ;;(format t "tfile ~X dfile ~X~%"
263     ;; (alien:slot header 'exec_tfile)
264     ;; (alien:slot header 'exec_dfile))
265     (alien:alien-funcall (alien:extern-alien
266     "sanctify_for_execution"
267     (alien:function c-call:void
268     alien:system-area-pointer
269     c-call:unsigned-long))
270     addr (+ (- dmem tmem) dsize bsize))
271     ))
272 wlott 1.8 (unix:unix-close fd))))
273 ram 1.1
274 wlott 1.3 (defun parse-symbol-table (name)
275     (format t ";;; Parsing symbol table...~%")
276     (let ((symbol-table (make-hash-table :test #'equal)))
277     (with-open-file (file name)
278     (loop
279     (let ((line (read-line file nil nil)))
280     (unless line
281     (return))
282     (let* ((symbol (subseq line 11))
283     (address (parse-integer line :end 8 :radix 16))
284     (old-address (gethash symbol lisp::*foreign-symbols*)))
285     (unless (or (null old-address) (= address old-address))
286     (warn "~S moved from #x~8,'0X to #x~8,'0X.~%"
287     symbol old-address address))
288     (setf (gethash symbol symbol-table) address)))))
289     (setf lisp::*foreign-symbols* symbol-table)))
290 ram 1.1
291 ram 1.11 (defun load-foreign (files &key
292 ram 1.1 (libraries '("-lc"))
293 ram 1.12 (base-file
294     (merge-pathnames *command-line-utility-name*
295     "path:"))
296 wlott 1.3 (env ext:*environment-list*))
297 ram 1.11 "Load-foreign loads a list of C object files into a running Lisp. The files
298     argument should be a single file or a list of files. The files may be
299     specified as namestrings or as pathnames. The libraries argument should be a
300     list of library files as would be specified to ld. They will be searched in
301     the order given. The default is just \"-lc\", i.e., the C library. The
302     base-file argument is used to specify a file to use as the starting place for
303     defined symbols. The default is the C start up code for Lisp. The env
304     argument is the Unix environment variable definitions for the invocation of
305     the linker. The default is the environment passed to Lisp."
306 wlott 1.3 (let ((output-file (pick-temporary-file-name))
307     (symbol-table-file (pick-temporary-file-name))
308     (error-output (make-string-output-stream)))
309 ram 1.7
310 ram 1.11 (format t ";;; Running library:load-foreign.csh...~%")
311 wlott 1.3 (force-output)
312 wlott 1.14 (let ((proc (ext:run-program
313     "library:load-foreign.csh"
314     (list* (or *previous-linked-object-file*
315     (namestring (truename base-file)))
316     (format nil "~X"
317     *foreign-segment-free-pointer*)
318     output-file
319     symbol-table-file
320     (append (mapcar #'(lambda (name)
321     (unix-namestring name nil))
322     (if (atom files)
323     (list files)
324     files))
325     libraries))
326     :env env
327     :input nil
328     :output error-output
329     :error :output)))
330 wlott 1.3 (unless proc
331 ram 1.11 (error "Could not run library:load-foreign.csh"))
332 wlott 1.3 (unless (zerop (ext:process-exit-code proc))
333     (system:serve-all-events 0)
334 ram 1.11 (error "library:load-foreign.csh failed:~%~A"
335     (get-output-stream-string error-output)))
336 wlott 1.3 (load-object-file output-file)
337     (parse-symbol-table symbol-table-file)
338 wlott 1.8 (unix:unix-unlink symbol-table-file)
339 wlott 1.3 (let ((old-file *previous-linked-object-file*))
340     (setf *previous-linked-object-file* output-file)
341     (when old-file
342 wlott 1.8 (unix:unix-unlink old-file)))))
343 wlott 1.3 (format t ";;; Done.~%"))

  ViewVC Help
Powered by ViewVC 1.1.5