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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5