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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5