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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (hide annotations)
Fri Jul 17 16:03:41 1992 UTC (21 years, 9 months ago) by ram
Branch: MAIN
Changes since 1.11: +4 -2 lines
Changed default base file name for load-foreign to be the name used to run
lisp, and not "lisp".
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.12 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/foreign.lisp,v 1.12 1992/07/17 16:03:41 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.4
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 wlott 1.8 (let ((name (format nil base (unix:unix-getpid) (code-char code))))
28 wlott 1.3 (multiple-value-bind
29     (fd errno)
30 wlott 1.8 (unix:unix-open name
31     (logior unix:o_wronly unix:o_creat unix:o_excl)
32 wlott 1.3 #o666)
33     (cond ((not (null fd))
34 wlott 1.8 (unix:unix-close fd)
35 wlott 1.3 (return name))
36 wlott 1.8 ((not (= errno unix:eexist))
37 wlott 1.3 (error "Could not create temporary file ~S: ~A"
38 wlott 1.8 name (unix:get-unix-error-msg errno)))
39 wlott 1.3
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 wlott 1.8 (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 ram 1.1
59 wlott 1.3 (defun allocate-space-in-foreign-segment (bytes)
60 ram 1.6 (let* ((pagesize-1 (1- (get-page-size)))
61 wlott 1.3 (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 wlott 1.10 (allocate-system-memory-at addr memory-needed)
68 wlott 1.3 addr))
69 ram 1.1
70 wlott 1.3 #+sparc
71     (defun load-object-file (name)
72     (format t ";;; Loading object file...~%")
73 wlott 1.8 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
74 wlott 1.3 (unless fd
75 wlott 1.8 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
76 wlott 1.3 (unwind-protect
77 wlott 1.8 (alien:with-alien ((header exec))
78     (unix:unix-read fd
79     (alien:alien-sap header)
80     (alien:alien-size exec :bytes))
81 wlott 1.3 (let* ((len-of-text-and-data
82 wlott 1.8 (+ (alien:slot header 'text) (alien:slot header 'data)))
83 wlott 1.3 (memory-needed
84 wlott 1.8 (+ len-of-text-and-data (alien:slot header 'bss)))
85 wlott 1.3 (addr (allocate-space-in-foreign-segment memory-needed)))
86 wlott 1.8 (unix:unix-read fd addr len-of-text-and-data)))
87     (unix:unix-close fd))))
88 ram 1.1
89 wlott 1.3 #+pmax
90 wlott 1.8 (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 ram 1.1
100 wlott 1.3 #+pmax
101 wlott 1.8 (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 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 wlott 1.8 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
123 wlott 1.3 (unless fd
124 wlott 1.8 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
125 wlott 1.3 (unwind-protect
126 wlott 1.8 (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 ram 1.1
150 wlott 1.3 (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 ram 1.1
167 ram 1.11 (defun load-foreign (files &key
168 ram 1.1 (libraries '("-lc"))
169 ram 1.12 (base-file
170     (merge-pathnames *command-line-utility-name*
171     "path:"))
172 wlott 1.3 (env ext:*environment-list*))
173 ram 1.11 "Load-foreign loads a list of C object files into a running Lisp. The files
174     argument should be a single file or a list of files. The files may be
175     specified as namestrings or as pathnames. The libraries argument should be a
176     list of library files as would be specified to ld. They will be searched in
177     the order given. The default is just \"-lc\", i.e., the C library. The
178     base-file argument is used to specify a file to use as the starting place for
179     defined symbols. The default is the C start up code for Lisp. The env
180     argument is the Unix environment variable definitions for the invocation of
181     the linker. The default is the environment passed to Lisp."
182 wlott 1.3 (let ((output-file (pick-temporary-file-name))
183     (symbol-table-file (pick-temporary-file-name))
184     (error-output (make-string-output-stream)))
185 ram 1.7
186 ram 1.11 (format t ";;; Running library:load-foreign.csh...~%")
187 wlott 1.3 (force-output)
188 ram 1.11 (let ((proc (ext:run-program "library:load-foreign.csh"
189 wlott 1.3 (list* (or *previous-linked-object-file*
190 ram 1.7 (namestring (truename base-file)))
191 wlott 1.3 (format nil "~X"
192     *foreign-segment-free-pointer*)
193     output-file
194     symbol-table-file
195     (append (if (atom files)
196     (list files)
197     files)
198     libraries))
199     :env env
200     :input nil
201     :output error-output
202     :error :output)))
203     (unless proc
204 ram 1.11 (error "Could not run library:load-foreign.csh"))
205 wlott 1.3 (unless (zerop (ext:process-exit-code proc))
206     (system:serve-all-events 0)
207 ram 1.11 (error "library:load-foreign.csh failed:~%~A"
208     (get-output-stream-string error-output)))
209 wlott 1.3 (load-object-file output-file)
210     (parse-symbol-table symbol-table-file)
211 wlott 1.8 (unix:unix-unlink symbol-table-file)
212 wlott 1.3 (let ((old-file *previous-linked-object-file*))
213     (setf *previous-linked-object-file* output-file)
214     (when old-file
215 wlott 1.8 (unix:unix-unlink old-file)))))
216 wlott 1.3 (format t ";;; Done.~%"))

  ViewVC Help
Powered by ViewVC 1.1.5