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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (hide annotations)
Mon Mar 2 02:27:23 1992 UTC (22 years, 1 month ago) by wlott
Branch: MAIN
Changes since 1.9: +2 -2 lines
Don't use MACH:VM-ALLOCATE, because we might not be running under mach.
Use ALLOCATE-SYSTEM-MEMORY-AT instead.
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 wlott 1.10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/foreign.lisp,v 1.10 1992/03/02 02:27:23 wlott 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 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     (defun load-foreign (files &optional
168     (libraries '("-lc"))
169 ram 1.7 (linker "library:load-foreign.csh")
170     (base-file "path:lisp")
171 wlott 1.3 (env ext:*environment-list*))
172 ram 1.1 "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 wlott 1.3 (let ((output-file (pick-temporary-file-name))
185     (symbol-table-file (pick-temporary-file-name))
186     (error-output (make-string-output-stream)))
187 ram 1.7
188 wlott 1.3 (format t ";;; Running ~A...~%" linker)
189     (force-output)
190     (let ((proc (ext:run-program linker
191     (list* (or *previous-linked-object-file*
192 ram 1.7 (namestring (truename base-file)))
193 wlott 1.3 (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 wlott 1.8 (unix:unix-unlink symbol-table-file)
214 wlott 1.3 (let ((old-file *previous-linked-object-file*))
215     (setf *previous-linked-object-file* output-file)
216     (when old-file
217 wlott 1.8 (unix:unix-unlink old-file)))))
218 wlott 1.3 (format t ";;; Done.~%"))

  ViewVC Help
Powered by ViewVC 1.1.5