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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5