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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (show annotations)
Sun Feb 7 21:17:12 1993 UTC (21 years, 2 months ago) by wlott
Branch: MAIN
Changes since 1.12: +7 -1 lines
Moved foreign-segment-{start,size} from mumble-os.lisp into foreign.lisp.
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.13 1993/02/07 21:17:12 wlott 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 (defvar *previous-linked-object-file* nil)
28 (defvar *foreign-segment-free-pointer* foreign-segment-start)
29
30 (defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C"))
31 (let ((code (char-code #\A)))
32 (loop
33 (let ((name (format nil base (unix:unix-getpid) (code-char code))))
34 (multiple-value-bind
35 (fd errno)
36 (unix:unix-open name
37 (logior unix:o_wronly unix:o_creat unix:o_excl)
38 #o666)
39 (cond ((not (null fd))
40 (unix:unix-close fd)
41 (return name))
42 ((not (= errno unix:eexist))
43 (error "Could not create temporary file ~S: ~A"
44 name (unix:get-unix-error-msg errno)))
45
46 ((= code (char-code #\Z))
47 (setf code (char-code #\a)))
48 ((= code (char-code #\z))
49 (return nil))
50 (t
51 (incf code))))))))
52
53 #+sparc
54 (alien:def-alien-type exec
55 (alien:struct nil
56 (magic c-call:unsigned-long)
57 (text c-call:unsigned-long)
58 (data c-call:unsigned-long)
59 (bss c-call:unsigned-long)
60 (syms c-call:unsigned-long)
61 (entry c-call:unsigned-long)
62 (trsize c-call:unsigned-long)
63 (drsize c-call:unsigned-long)))
64
65 (defun allocate-space-in-foreign-segment (bytes)
66 (let* ((pagesize-1 (1- (get-page-size)))
67 (memory-needed (logandc2 (+ bytes pagesize-1) pagesize-1))
68 (addr (int-sap *foreign-segment-free-pointer*))
69 (new-ptr (+ *foreign-segment-free-pointer* bytes)))
70 (when (> new-ptr (+ foreign-segment-start foreign-segment-size))
71 (error "Not enough memory left."))
72 (setf *foreign-segment-free-pointer* new-ptr)
73 (allocate-system-memory-at addr memory-needed)
74 addr))
75
76 #+sparc
77 (defun load-object-file (name)
78 (format t ";;; Loading object file...~%")
79 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
80 (unless fd
81 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
82 (unwind-protect
83 (alien:with-alien ((header exec))
84 (unix:unix-read fd
85 (alien:alien-sap header)
86 (alien:alien-size exec :bytes))
87 (let* ((len-of-text-and-data
88 (+ (alien:slot header 'text) (alien:slot header 'data)))
89 (memory-needed
90 (+ len-of-text-and-data (alien:slot header 'bss)))
91 (addr (allocate-space-in-foreign-segment memory-needed)))
92 (unix:unix-read fd addr len-of-text-and-data)))
93 (unix:unix-close fd))))
94
95 #+pmax
96 (alien:def-alien-type filehdr
97 (alien:struct nil
98 (magic c-call:unsigned-short)
99 (nscns c-call:unsigned-short)
100 (timdat c-call:long)
101 (symptr c-call:long)
102 (nsyms c-call:long)
103 (opthdr c-call:unsigned-short)
104 (flags c-call:unsigned-short)))
105
106 #+pmax
107 (alien:def-alien-type aouthdr
108 (alien:struct nil
109 (magic c-call:short)
110 (vstamp c-call:short)
111 (tsize c-call:long)
112 (dsize c-call:long)
113 (bsize c-call:long)
114 (entry c-call:long)
115 (text_start c-call:long)
116 (data_start c-call:long)))
117
118 #+pmax
119 (defconstant filhsz 20)
120 #+pmax
121 (defconstant aouthsz 56)
122 #+pmax
123 (defconstant scnhsz 40)
124
125 #+pmax
126 (defun load-object-file (name)
127 (format t ";;; Loading object file...~%")
128 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
129 (unless fd
130 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
131 (unwind-protect
132 (alien:with-alien ((filehdr filehdr)
133 (aouthdr aouthdr))
134 (unix:unix-read fd
135 (alien:alien-sap filehdr)
136 (alien:alien-size filehdr :bytes))
137 (unix:unix-read fd
138 (alien:alien-sap aouthdr)
139 (alien:alien-size aouthdr :bytes))
140 (let* ((len-of-text-and-data
141 (+ (alien:slot aouthdr 'tsize) (alien:slot aouthdr 'dsize)))
142 (memory-needed
143 (+ len-of-text-and-data (alien:slot aouthdr 'bsize)))
144 (addr (allocate-space-in-foreign-segment memory-needed))
145 (pad-size-1 (if (< (alien:slot aouthdr 'vstamp) 23) 7 15)))
146 (unix:unix-lseek fd
147 (logandc2 (+ filhsz aouthsz
148 (* scnhsz
149 (alien:slot filehdr 'nscns))
150 pad-size-1)
151 pad-size-1)
152 unix:l_set)
153 (unix:unix-read fd addr len-of-text-and-data)))
154 (unix:unix-close fd))))
155
156 (defun parse-symbol-table (name)
157 (format t ";;; Parsing symbol table...~%")
158 (let ((symbol-table (make-hash-table :test #'equal)))
159 (with-open-file (file name)
160 (loop
161 (let ((line (read-line file nil nil)))
162 (unless line
163 (return))
164 (let* ((symbol (subseq line 11))
165 (address (parse-integer line :end 8 :radix 16))
166 (old-address (gethash symbol lisp::*foreign-symbols*)))
167 (unless (or (null old-address) (= address old-address))
168 (warn "~S moved from #x~8,'0X to #x~8,'0X.~%"
169 symbol old-address address))
170 (setf (gethash symbol symbol-table) address)))))
171 (setf lisp::*foreign-symbols* symbol-table)))
172
173 (defun load-foreign (files &key
174 (libraries '("-lc"))
175 (base-file
176 (merge-pathnames *command-line-utility-name*
177 "path:"))
178 (env ext:*environment-list*))
179 "Load-foreign loads a list of C object files into a running Lisp. The files
180 argument should be a single file or a list of files. The files may be
181 specified as namestrings or as pathnames. The libraries argument should be a
182 list of library files as would be specified to ld. They will be searched in
183 the order given. The default is just \"-lc\", i.e., the C library. The
184 base-file argument is used to specify a file to use as the starting place for
185 defined symbols. The default is the C start up code for Lisp. The env
186 argument is the Unix environment variable definitions for the invocation of
187 the linker. The default is the environment passed to Lisp."
188 (let ((output-file (pick-temporary-file-name))
189 (symbol-table-file (pick-temporary-file-name))
190 (error-output (make-string-output-stream)))
191
192 (format t ";;; Running library:load-foreign.csh...~%")
193 (force-output)
194 (let ((proc (ext:run-program "library:load-foreign.csh"
195 (list* (or *previous-linked-object-file*
196 (namestring (truename base-file)))
197 (format nil "~X"
198 *foreign-segment-free-pointer*)
199 output-file
200 symbol-table-file
201 (append (if (atom files)
202 (list files)
203 files)
204 libraries))
205 :env env
206 :input nil
207 :output error-output
208 :error :output)))
209 (unless proc
210 (error "Could not run library:load-foreign.csh"))
211 (unless (zerop (ext:process-exit-code proc))
212 (system:serve-all-events 0)
213 (error "library:load-foreign.csh failed:~%~A"
214 (get-output-stream-string error-output)))
215 (load-object-file output-file)
216 (parse-symbol-table symbol-table-file)
217 (unix:unix-unlink symbol-table-file)
218 (let ((old-file *previous-linked-object-file*))
219 (setf *previous-linked-object-file* output-file)
220 (when old-file
221 (unix:unix-unlink old-file)))))
222 (format t ";;; Done.~%"))

  ViewVC Help
Powered by ViewVC 1.1.5