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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Fri Jun 15 22:54:24 1990 UTC (23 years, 10 months ago) by ram
Branch: MAIN
Changes since 1.1: +4 -5 lines
Changed to use pointer< and sap+ instead of >= and + when operating on
saps.
1 ram 1.1 ;;; -*- Log: code.log; Package: Extensions -*-
2    
3     ;;; **********************************************************************
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    
10     ;;; Functions for dealing with foreign function calls in Common Lisp.
11    
12     ;;; Written by David B. McDonald, January 1987.
13    
14     ;;; *******************************************************************
15     (in-package "EXTENSIONS" :nicknames '("EXT") :use '("LISP" "SYSTEM"))
16    
17     (export '(load-foreign get-code-pointer get-data-pointer))
18    
19     (defconstant Unix-OMagic #x107)
20     (defconstant Unix-NMagic #x108)
21     (defconstant Unix-ZMagic #x10b)
22    
23     (defconstant Unix-header-size 32)
24     (defconstant Symbol-Table-Entry-Size 12)
25    
26     (defconstant n_undf #x0)
27     (defconstant n_abs #x2)
28     (defconstant n_text #x4)
29     (defconstant n_data #x6)
30     (defconstant n_bss #x8)
31     (defconstant n_comm #x12)
32     (defconstant n_fn #x1f)
33     (defconstant n_ext #x1)
34    
35     (defvar file-count 0
36     "Number of foreign function files loaded into the current Lisp.")
37    
38     (defvar temporary-foreign-files NIL
39     "List of dotted pairs containing location and size of object code
40     loaded so that foreign functions can be called.")
41    
42     (proclaim '(fixnum file-count))
43    
44     (defstruct unix-ste
45     (type 0 :type fixnum)
46     (location 0))
47    
48    
49     (defvar foreign-symbols (make-hash-table :size 1000 :test #'equal))
50    
51     (defmacro read-cword (sap offset)
52     `(let ((rsap ,sap)
53     (roff ,offset))
54     (declare (fixnum roff))
55     (setq roff (the fixnum (ash roff 1)))
56     (logior (ash (%primitive 16bit-system-ref rsap roff) 16)
57     (%primitive 16bit-system-ref rsap (the fixnum (1+ roff))))))
58    
59     (defun read-miscop-free-pointer ()
60     (let ((aa lisp::alloctable-address)
61     (in (ash lisp::%assembler-code-type lisp::%alloc-ref-type-shift)))
62     (declare (fixnum in))
63     (logand (+ (logior (%primitive 16bit-system-ref aa (the fixnum (1+ in)))
64     (ash (%primitive 16bit-system-ref aa in) 16)) 3)
65     (lognot 3))))
66    
67     (defun write-miscop-free-pointer (value)
68     (let ((aa lisp::alloctable-address)
69     (in (ash lisp::%assembler-code-type lisp::%alloc-ref-type-shift))
70     (vl (logand value #xFFFF))
71     (vh (logand (ash value -16) #xFFFF)))
72     (declare (fixnum in))
73     (%primitive 16bit-system-set aa (the fixnum (1+ in)) vl)
74     (%primitive 16bit-system-set aa in vh)))
75    
76     ;;; Load-foreign accepts a file or a list of files to be loaded into the
77     ;;; currently running Lisp core. These files should be standard object
78     ;;; files created by you favourite compiler (e.g., cc). It accepts two
79     ;;; optional parameters: libraries is a list of libraries to search
80     ;;; for unresolved references (default is the standard C library), and
81     ;;; env which is a list of Unix environment strings (default is what
82     ;;; lisp started with). Load-foreign runs ld creating an object file
83     ;;; that has been linked so that it can be loaded into a predetermined
84     ;;; location in memory.
85    
86     (defun load-foreign (files &optional
87     (libraries '("-lc"))
88     (linker "/usr/cs/bin/ld")
89     (base-file "/usr/misc/.lisp/bin/lisp")
90     (env lisp::original-lisp-environment))
91     "Load-foreign loads a list of C object files into a running Lisp. The
92     files argument should be a single file or a list of files. The files
93     may be specified as namestrings or as pathnames. The libraries
94     argument should be a list of library files as would be specified to
95     ld. They will be searched in the order given. The default is just
96     \"-lc\", i.e., the C library. The linker argument is used to specifier
97     the Unix linker to use to link the object files (the default is
98     /usr/cs/bin/ld). The base-file argument is used to specify a file to
99     use as the starting place for defined symbols. The default is the C
100     start up code for Lisp. The env argument is the Unix environment
101     variable definitions for the invocation of the linker. The default is
102     the environment passed to Lisp."
103     (if (null (listp files)) (setq files (list files)))
104     (format t "[Loading foreign files ~A ...~%" files)
105     (let ((tfl (if files (format nil "/tmp/L~d.~d"
106     (mach:unix-getuid)
107     (the fixnum (+ (the fixnum (mach:unix-getpid))
108     file-count)))
109     base-file))
110     (ofl (get-last-loaded-file file-count base-file))
111     (addr (read-miscop-free-pointer)))
112     (when files
113     (setq file-count (the fixnum (1+ file-count)))
114     (format t " [Running ld ...")
115     (force-output t)
116     (let ((nfiles ()))
117     (dolist (f files)
118     (let* ((pn (merge-pathnames f *default-pathname-defaults*))
119     (tn (probe-file pn)))
120     (push (if tn (namestring tn) f) nfiles)))
121     (setf files (nreverse nfiles)))
122     (run-program linker `("-N" "-A" ,ofl "-T"
123     ,(format nil "~X" (+ addr unix-header-size))
124     "-o" ,tfl ,@files ,@libraries)
125     :env env :wait t :output t :error t)
126     (push tfl temporary-foreign-files)
127     (format t " done.]~%"))
128     (multiple-value-bind (res dev ino mode nlnk uid gid rdev len)
129     (mach:unix-stat tfl)
130     (declare (ignore ino mode nlnk uid gid rdev))
131     (when (null res)
132     (error "Could not stat intermediate file ~a, unix error: ~A."
133     tfl (mach:get-unix-error-msg dev)))
134     (format t " [Reading Unix object file ...")
135     (force-output t)
136     (multiple-value-bind (fd err) (mach:unix-open tfl mach:o_rdonly 0)
137     (when (null fd)
138     (error "Failed to open intermediate file ~A, unix error: ~A."
139     (mach:get-unix-error-msg err)))
140     (multiple-value-bind (bytes err2)
141     (mach:unix-read fd (int-sap addr)
142     len)
143     (when (or (null bytes) (not (eq bytes len)))
144     (if (null bytes)
145     (error "Read of intermediate file ~A failed, unix error: ~A"
146     tfl (mach:get-unix-error-msg err2))
147     (error "Read of intermediate file ~A only read ~d of ~d bytes."
148     tfl bytes len))))
149     (mach:unix-close fd)))
150     (format t " done.]~%")
151     (let ((fsize (logand (+ (load-object-file tfl addr files) 4) (lognot 3))))
152     (when files (write-miscop-free-pointer (+ addr fsize)))))
153     (format t "done.]~%"))
154    
155     ;;; Get-last-loaded-file attempts to find the file that was last loaded into
156     ;;; Lisp. If one is found, load-foreign uses it as the bases for the initial
157     ;;; symbol table. Otherwise, it uses the lisp startup code.
158    
159     (defun get-last-loaded-file (fc base-file)
160     (declare (fixnum fc))
161     (do ((i (the fixnum (1- fc)) (1- i)))
162     ((< i 0) base-file)
163     (declare (fixnum i))
164     (let ((tfl (format nil "/tmp/L~d.~d" (mach:unix-getuid)
165     (the fixnum (+ (the fixnum (mach:unix-getpid)) i)))))
166     (if (probe-file tfl) (return tfl)))))
167    
168     ;;; Load-object-file, actually loads the object file created by ld.
169     ;;; It makes sure that it is a legal object file.
170    
171     (defun load-object-file (file addr flag)
172     (format t " [Loading symbol table information ...")
173     (force-output t)
174     (let* ((sap (int-sap addr))
175     (magic (read-cword sap 0))
176     (text-size (read-cword sap 1))
177     (idata-size (read-cword sap 2))
178     (udata-size (read-cword sap 3))
179     (symtab-size (read-cword sap 4))
180     (epoint (read-cword sap 5))
181     (treloc-size (read-cword sap 6))
182     (dreloc-size (read-cword sap 7))
183     (load-size (+ text-size idata-size udata-size unix-header-size))
184     (symstart (+ text-size idata-size (if flag unix-header-size 2048)))
185     (strstart (+ symstart (the fixnum symtab-size))))
186     (declare (fixnum magic text-size idata-size udata-size
187     symtab-size symstart strstart treloc-size
188     dreloc-size)
189     (ignore epoint))
190     (unless (or (null flag)
191     (and (= magic unix-OMagic) (= treloc-size 0) (= dreloc-size 0)))
192     (error "File ~A is not a legal Unix object file." file))
193 ram 1.2 (read-symbol-table (%primitive sap+ sap symstart) symtab-size (%primitive sap+ sap strstart))
194 ram 1.1 (setq load-size (logand (the fixnum (+ load-size 8192)) (lognot 8191)))
195     (do ((ind (truncate (+ text-size idata-size unix-header-size) 2)
196     (1+ ind))
197     (end (truncate udata-size 2)))
198     ((>= ind end))
199     (%primitive 16bit-system-set sap ind 0))
200     (format t " done.]~%")
201     load-size))
202    
203     ;;; Read-symbol-table reads the symbol table out of the object, making
204     ;;; external symbols available to Lisp, so that they can be used to
205     ;;; link to the C routines.
206    
207     (defun read-symbol-table (symstart symtab-size strstart)
208 ram 1.2 (let ((end (%primitive sap+ symstart symtab-size)))
209     (do* ((se symstart (%primitive sap+ se symbol-table-entry-size))
210 ram 1.1 (si (logior (ash (%primitive 16bit-system-ref se 0) 16)
211     (%primitive 16bit-system-ref se 1))
212     (logior (ash (%primitive 16bit-system-ref se 0) 16)
213     (%primitive 16bit-system-ref se 1)))
214     (st (%primitive 8bit-system-ref se 4)
215     (%primitive 8bit-system-ref se 4))
216     (sv (logior (ash (%primitive 16bit-system-ref se 4) 16)
217     (%primitive 16bit-system-ref se 5))
218     (logior (ash (%primitive 16bit-system-ref se 4) 16)
219     (%primitive 16bit-system-ref se 5))))
220 ram 1.2 ((not (%primitive pointer< se end)))
221 ram 1.1 (declare (fixnum st))
222     (when (or (= st (logior n_text n_ext))
223     (= st (logior n_data n_ext))
224     (= st (logior n_bss n_ext)))
225     (let* ((strend (%primitive find-character strstart si (+ si 512) 0)))
226     (when (null strend)
227     (error "Symbol table string didn't terminate."))
228     (let ((strlen (the fixnum (- (the fixnum strend) (the fixnum si))))
229     (offset 0)
230     (code NIL)
231     (str NIL))
232     (declare (fixnum strlen offset))
233     (when (eq (%primitive 8bit-system-ref strstart si) (char-code #\_))
234     (setq offset (the fixnum (1+ offset)))
235     (when (eq (%primitive 8bit-system-ref strstart
236     (the fixnum (1+ (the fixnum si))))
237     (char-code #\.))
238     (setq code T)
239     (setq offset (the fixnum (1+ offset)))))
240     (setq str (make-string (the fixnum (- strlen offset))))
241     (%primitive byte-blt strstart
242     (the fixnum (+ (the fixnum si) offset)) str 0 strlen)
243     (if (let ((x (ash sv (- (+ clc::type-shift-16 16)))))
244     (not (<= clc::first-pointer-type x clc::last-pointer-type)))
245     (let ((ste (gethash str foreign-symbols))
246     (loc (int-sap sv)))
247     (cond ((null ste)
248     (setf (gethash str foreign-symbols)
249     (make-unix-ste :type (if code
250     (logior n_text
251     n_ext) st)
252     :location (if code nil loc))))
253     (code
254     (setf (unix-ste-type ste) (logior n_text n_ext)))
255     (T
256     (setf (unix-ste-location ste) loc)))))))))))
257    
258     ;;; Get-code-pointer accepts a simple string which should be the name
259     ;;; of a C routine that has already been loaded into the Lisp core image.
260     ;;; This name should use the correct capitalization of the C name without
261     ;;; the default underscore.
262     (defun get-code-pointer (name)
263     (let ((ste (gethash name foreign-symbols)))
264     (when (null ste)
265     (error "There is no foreign function named ~A loaded." name))
266     (when (not (eq (unix-ste-type ste) (logior n_text n_ext)))
267     (error "~A is a foreign external variable, not a foreign function." name))
268     (unix-ste-location ste)))
269    
270    
271     ;;; Get-data-pointer is similar to get-code-pointer, except it returns the
272     ;;; address of a foreign global variable.
273    
274     (defun get-data-pointer (name)
275     (let ((ste (gethash name foreign-symbols)))
276     (when (null ste)
277     (error "There is no foreign variable named ~A loaded." name))
278     (when (eq (unix-ste-type ste) (logior n_text n_ext))
279     (error "~A is a foreign function, not a foreign variable." name))
280     (unix-ste-location ste)))

  ViewVC Help
Powered by ViewVC 1.1.5