Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Carl Shapiro
cmucl
Commits
9d39632f
Commit
9d39632f
authored
34 years ago
by
wlott
Browse files
Options
Downloads
Patches
Plain Diff
Totally re-written for the new system.
parent
877439a6
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
code/foreign.lisp
+205
-256
205 additions, 256 deletions
code/foreign.lisp
with
205 additions
and
256 deletions
code/foreign.lisp
+
205
−
256
View file @
9d39632f
;;; -*-
Log: code.log; Package: Extensions
-*-
;;; -*-
Package: SYSTEM
-*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;; Functions for dealing with foreign function calls in Common Lisp.
;;; Written by David B. McDonald, January 1987.
;;; *******************************************************************
(
in-package
"EXTENSIONS"
:nicknames
'
(
"EXT"
)
:use
'
(
"LISP"
"SYSTEM"
))
(
export
'
(
load-foreign
get-code-pointer
get-data-pointer
))
(
defconstant
Unix-OMagic
#x107
)
(
defconstant
Unix-NMagic
#x108
)
(
defconstant
Unix-ZMagic
#x10b
)
(
defconstant
Unix-header-size
32
)
(
defconstant
Symbol-Table-Entry-Size
12
)
(
defconstant
n_undf
#x0
)
(
defconstant
n_abs
#x2
)
(
defconstant
n_text
#x4
)
(
defconstant
n_data
#x6
)
(
defconstant
n_bss
#x8
)
(
defconstant
n_comm
#x12
)
(
defconstant
n_fn
#x1f
)
(
defconstant
n_ext
#x1
)
(
defvar
file-count
0
"Number of foreign function files loaded into the current Lisp."
)
(
defvar
temporary-foreign-files
NIL
"List of dotted pairs containing location and size of object code
loaded so that foreign functions can be called."
)
(
proclaim
'
(
fixnum
file-count
))
(
defstruct
unix-ste
(
type
0
:type
fixnum
)
(
location
0
))
(
defvar
foreign-symbols
(
make-hash-table
:size
1000
:test
#'
equal
))
(
defmacro
read-cword
(
sap
offset
)
`
(
let
((
rsap
,
sap
)
(
roff
,
offset
))
(
declare
(
fixnum
roff
))
(
setq
roff
(
the
fixnum
(
ash
roff
1
)))
(
logior
(
ash
(
%primitive
16bit-system-ref
rsap
roff
)
16
)
(
%primitive
16bit-system-ref
rsap
(
the
fixnum
(
1+
roff
))))))
(
defun
read-miscop-free-pointer
()
(
let
((
aa
lisp::alloctable-address
)
(
in
(
ash
lisp::%assembler-code-type
lisp::%alloc-ref-type-shift
)))
(
declare
(
fixnum
in
))
(
logand
(
+
(
logior
(
%primitive
16bit-system-ref
aa
(
the
fixnum
(
1+
in
)))
(
ash
(
%primitive
16bit-system-ref
aa
in
)
16
))
3
)
(
lognot
3
))))
(
defun
write-miscop-free-pointer
(
value
)
(
let
((
aa
lisp::alloctable-address
)
(
in
(
ash
lisp::%assembler-code-type
lisp::%alloc-ref-type-shift
))
(
vl
(
logand
value
#xFFFF
))
(
vh
(
logand
(
ash
value
-16
)
#xFFFF
)))
(
declare
(
fixnum
in
))
(
%primitive
16bit-system-set
aa
(
the
fixnum
(
1+
in
))
vl
)
(
%primitive
16bit-system-set
aa
in
vh
)))
;;; Load-foreign accepts a file or a list of files to be loaded into the
;;; currently running Lisp core. These files should be standard object
;;; files created by you favourite compiler (e.g., cc). It accepts two
;;; optional parameters: libraries is a list of libraries to search
;;; for unresolved references (default is the standard C library), and
;;; env which is a list of Unix environment strings (default is what
;;; lisp started with). Load-foreign runs ld creating an object file
;;; that has been linked so that it can be loaded into a predetermined
;;; location in memory.
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.3 1991/01/31 01:20:54 wlott Exp $
;;;
;;; Load-foreign and support routines.
;;;
(
in-package
"SYSTEM"
)
(
export
'
(
load-foreign
))
(
defconstant
foreign-segment-start
#x00C00000
)
(
defconstant
foreign-segment-size
#x00400000
)
(
defvar
*previous-linked-object-file*
nil
)
(
defvar
*foreign-segment-free-pointer*
foreign-segment-start
)
(
defun
pick-temporary-file-name
(
&optional
(
base
"/tmp/tmp~D~C"
))
(
let
((
code
(
char-code
#\A
)))
(
loop
(
let
((
name
(
format
nil
base
(
mach:unix-getpid
)
(
code-char
code
))))
(
multiple-value-bind
(
fd
errno
)
(
mach:unix-open
name
(
logior
mach:o_wronly
mach:o_creat
mach:o_excl
)
#o666
)
(
cond
((
not
(
null
fd
))
(
mach:unix-close
fd
)
(
return
name
))
((
not
(
=
errno
mach:eexist
))
(
error
"Could not create temporary file ~S: ~A"
name
(
mach:get-unix-error-msg
errno
)))
((
=
code
(
char-code
#\Z
))
(
setf
code
(
char-code
#\a
)))
((
=
code
(
char-code
#\z
))
(
return
nil
))
(
t
(
incf
code
))))))))
#+
sparc
(
ext:def-c-record
exec
(
magic
ext:unsigned-long
)
(
text
ext:unsigned-long
)
(
data
ext:unsigned-long
)
(
bss
ext:unsigned-long
)
(
syms
ext:unsigned-long
)
(
entry
ext:unsigned-long
)
(
trsize
ext:unsigned-long
)
(
drsize
ext:unsigned-long
))
(
defun
allocate-space-in-foreign-segment
(
bytes
)
(
let*
((
pagesize-1
(
1-
(
gr-call*
mach:vm_statistics
*task-self*
)))
(
memory-needed
(
logandc2
(
+
bytes
pagesize-1
)
pagesize-1
))
(
addr
(
int-sap
*foreign-segment-free-pointer*
))
(
new-ptr
(
+
*foreign-segment-free-pointer*
bytes
)))
(
when
(
>
new-ptr
(
+
foreign-segment-start
foreign-segment-size
))
(
error
"Not enough memory left."
))
(
setf
*foreign-segment-free-pointer*
new-ptr
)
(
gr-call*
mach:vm_allocate
*task-self*
addr
memory-needed
nil
)
addr
))
#+
sparc
(
defun
load-object-file
(
name
)
(
format
t
";;; Loading object file...~%"
)
(
multiple-value-bind
(
fd
errno
)
(
mach:unix-open
name
mach:o_rdonly
0
)
(
unless
fd
(
error
"Could not open ~S: ~A"
name
(
mach:get-unix-error-msg
errno
)))
(
unwind-protect
(
with-stack-alien
(
header
exec
#.
(
ext:c-sizeof
'exec
))
(
mach:unix-read
fd
(
alien-sap
(
alien-value
header
))
(
truncate
(
alien-size
(
alien-value
header
))
(
bytes
1
)))
(
let*
((
len-of-text-and-data
(
+
(
alien-access
(
exec-text
(
alien-value
header
)))
(
alien-access
(
exec-data
(
alien-value
header
)))))
(
memory-needed
(
+
len-of-text-and-data
(
alien-access
(
exec-bss
(
alien-value
header
)))))
(
addr
(
allocate-space-in-foreign-segment
memory-needed
)))
(
mach:unix-read
fd
addr
len-of-text-and-data
)))
(
mach:unix-close
fd
))))
#+
pmax
(
ext:def-c-record
filehdr
(
magic
ext:unsigned-short
)
(
nscns
ext:unsigned-short
)
(
timdat
ext:long
)
(
symptr
ext:long
)
(
nsyms
ext:long
)
(
opthdr
ext:unsigned-short
)
(
flags
ext:unsigned-short
))
#+
pmax
(
ext:def-c-record
aouthdr
(
magic
ext:short
)
(
vstamp
ext:short
)
(
tsize
ext:long
)
(
dsize
ext:long
)
(
bsize
ext:long
)
(
entry
ext:long
)
(
text_start
ext:long
)
(
data_start
ext:long
))
#+
pmax
(
defconstant
filhsz
20
)
#+
pmax
(
defconstant
aouthsz
56
)
#+
pmax
(
defconstant
scnhsz
40
)
#+
pmax
(
defun
load-object-file
(
name
)
(
format
t
";;; Loading object file...~%"
)
(
multiple-value-bind
(
fd
errno
)
(
mach:unix-open
name
mach:o_rdonly
0
)
(
unless
fd
(
error
"Could not open ~S: ~A"
name
(
mach:get-unix-error-msg
errno
)))
(
unwind-protect
(
with-stack-alien
(
filehdr
filehdr
#.
(
ext:c-sizeof
'filehdr
))
(
with-stack-alien
(
aouthdr
aouthdr
#.
(
ext:c-sizeof
'aouthdr
))
(
mach:unix-read
fd
(
alien-sap
(
alien-value
filehdr
))
(
truncate
(
alien-size
(
alien-value
filehdr
))
(
bytes
1
)))
(
mach:unix-read
fd
(
alien-sap
(
alien-value
aouthdr
))
(
truncate
(
alien-size
(
alien-value
aouthdr
))
(
bytes
1
)))
(
let*
((
len-of-text-and-data
(
+
(
alien-access
(
aouthdr-tsize
(
alien-value
aouthdr
)))
(
alien-access
(
aouthdr-dsize
(
alien-value
aouthdr
)))))
(
memory-needed
(
+
len-of-text-and-data
(
alien-access
(
aouthdr-bsize
(
alien-value
aouthdr
)))))
(
addr
(
allocate-space-in-foreign-segment
memory-needed
))
(
pad-size-1
(
if
(
<
(
alien-access
(
aouthdr-vstamp
(
alien-value
aouthdr
)))
23
)
7
15
)))
(
mach:unix-lseek
fd
(
logandc2
(
+
filhsz
aouthsz
(
*
scnhsz
(
alien-access
(
filehdr-nscns
(
alien-value
filehdr
))))
pad-size-1
)
pad-size-1
)
mach:l_set
)
(
mach:unix-read
fd
addr
len-of-text-and-data
))))
(
mach:unix-close
fd
))))
(
defun
parse-symbol-table
(
name
)
(
format
t
";;; Parsing symbol table...~%"
)
(
let
((
symbol-table
(
make-hash-table
:test
#'
equal
)))
(
with-open-file
(
file
name
)
(
loop
(
let
((
line
(
read-line
file
nil
nil
)))
(
unless
line
(
return
))
(
let*
((
symbol
(
subseq
line
11
))
(
address
(
parse-integer
line
:end
8
:radix
16
))
(
old-address
(
gethash
symbol
lisp::*foreign-symbols*
)))
(
unless
(
or
(
null
old-address
)
(
=
address
old-address
))
(
warn
"~S moved from #x~8,'0X to #x~8,'0X.~%"
symbol
old-address
address
))
(
setf
(
gethash
symbol
symbol-table
)
address
)))))
(
setf
lisp::*foreign-symbols*
symbol-table
)))
(
defun
load-foreign
(
files
&optional
(
libraries
'
(
"-lc"
))
(
linker
"/usr/
cs/bin/ld
"
)
(
base-file
"/usr/misc/.
lisp
/bin/lisp"
)
(
env
lisp::original-lisp-
environment
))
(
linker
"/usr/
misc/.cmucl/lib/load-foreign.csh
"
)
(
base-file
"/usr/misc/.
cmucl
/bin/lisp"
)
(
env
ext:*
environment
-list*
))
"Load-foreign loads a list of C object files into a running Lisp. The
files argument should be a single file or a list of files. The files
may be specified as namestrings or as pathnames. The libraries
...
...
@@ -100,181 +190,40 @@
start up code for Lisp. The env argument is the Unix environment
variable definitions for the invocation of the linker. The default is
the environment passed to Lisp."
(
if
(
null
(
listp
files
))
(
setq
files
(
list
files
)))
(
format
t
"[Loading foreign files ~A ...~%"
files
)
(
let
((
tfl
(
if
files
(
format
nil
"/tmp/L~d.~d"
(
mach:unix-getuid
)
(
the
fixnum
(
+
(
the
fixnum
(
mach:unix-getpid
))
file-count
)))
base-file
))
(
ofl
(
get-last-loaded-file
file-count
base-file
))
(
addr
(
read-miscop-free-pointer
)))
(
when
files
(
setq
file-count
(
the
fixnum
(
1+
file-count
)))
(
format
t
" [Running ld ..."
)
(
force-output
t
)
(
let
((
nfiles
()))
(
dolist
(
f
files
)
(
let*
((
pn
(
merge-pathnames
f
*default-pathname-defaults*
))
(
tn
(
probe-file
pn
)))
(
push
(
if
tn
(
namestring
tn
)
f
)
nfiles
)))
(
setf
files
(
nreverse
nfiles
)))
(
run-program
linker
`
(
"-N"
"-A"
,
ofl
"-T"
,
(
format
nil
"~X"
(
+
addr
unix-header-size
))
"-o"
,
tfl
,@
files
,@
libraries
)
:env
env
:wait
t
:output
t
:error
t
)
(
push
tfl
temporary-foreign-files
)
(
format
t
" done.]~%"
))
(
multiple-value-bind
(
res
dev
ino
mode
nlnk
uid
gid
rdev
len
)
(
mach:unix-stat
tfl
)
(
declare
(
ignore
ino
mode
nlnk
uid
gid
rdev
))
(
when
(
null
res
)
(
error
"Could not stat intermediate file ~a, unix error: ~A."
tfl
(
mach:get-unix-error-msg
dev
)))
(
format
t
" [Reading Unix object file ..."
)
(
force-output
t
)
(
multiple-value-bind
(
fd
err
)
(
mach:unix-open
tfl
mach:o_rdonly
0
)
(
when
(
null
fd
)
(
error
"Failed to open intermediate file ~A, unix error: ~A."
(
mach:get-unix-error-msg
err
)))
(
multiple-value-bind
(
bytes
err2
)
(
mach:unix-read
fd
(
int-sap
addr
)
len
)
(
when
(
or
(
null
bytes
)
(
not
(
eq
bytes
len
)))
(
if
(
null
bytes
)
(
error
"Read of intermediate file ~A failed, unix error: ~A"
tfl
(
mach:get-unix-error-msg
err2
))
(
error
"Read of intermediate file ~A only read ~d of ~d bytes."
tfl
bytes
len
))))
(
mach:unix-close
fd
)))
(
format
t
" done.]~%"
)
(
let
((
fsize
(
logand
(
+
(
load-object-file
tfl
addr
files
)
4
)
(
lognot
3
))))
(
when
files
(
write-miscop-free-pointer
(
+
addr
fsize
)))))
(
format
t
"done.]~%"
))
;;; Get-last-loaded-file attempts to find the file that was last loaded into
;;; Lisp. If one is found, load-foreign uses it as the bases for the initial
;;; symbol table. Otherwise, it uses the lisp startup code.
(
defun
get-last-loaded-file
(
fc
base-file
)
(
declare
(
fixnum
fc
))
(
do
((
i
(
the
fixnum
(
1-
fc
))
(
1-
i
)))
((
<
i
0
)
base-file
)
(
declare
(
fixnum
i
))
(
let
((
tfl
(
format
nil
"/tmp/L~d.~d"
(
mach:unix-getuid
)
(
the
fixnum
(
+
(
the
fixnum
(
mach:unix-getpid
))
i
)))))
(
if
(
probe-file
tfl
)
(
return
tfl
)))))
;;; Load-object-file, actually loads the object file created by ld.
;;; It makes sure that it is a legal object file.
(
defun
load-object-file
(
file
addr
flag
)
(
format
t
" [Loading symbol table information ..."
)
(
force-output
t
)
(
let*
((
sap
(
int-sap
addr
))
(
magic
(
read-cword
sap
0
))
(
text-size
(
read-cword
sap
1
))
(
idata-size
(
read-cword
sap
2
))
(
udata-size
(
read-cword
sap
3
))
(
symtab-size
(
read-cword
sap
4
))
(
epoint
(
read-cword
sap
5
))
(
treloc-size
(
read-cword
sap
6
))
(
dreloc-size
(
read-cword
sap
7
))
(
load-size
(
+
text-size
idata-size
udata-size
unix-header-size
))
(
symstart
(
+
text-size
idata-size
(
if
flag
unix-header-size
2048
)))
(
strstart
(
+
symstart
(
the
fixnum
symtab-size
))))
(
declare
(
fixnum
magic
text-size
idata-size
udata-size
symtab-size
symstart
strstart
treloc-size
dreloc-size
)
(
ignore
epoint
))
(
unless
(
or
(
null
flag
)
(
and
(
=
magic
unix-OMagic
)
(
=
treloc-size
0
)
(
=
dreloc-size
0
)))
(
error
"File ~A is not a legal Unix object file."
file
))
(
read-symbol-table
(
%primitive
sap+
sap
symstart
)
symtab-size
(
%primitive
sap+
sap
strstart
))
(
setq
load-size
(
logand
(
the
fixnum
(
+
load-size
8192
))
(
lognot
8191
)))
(
do
((
ind
(
truncate
(
+
text-size
idata-size
unix-header-size
)
2
)
(
1+
ind
))
(
end
(
truncate
udata-size
2
)))
((
>=
ind
end
))
(
%primitive
16bit-system-set
sap
ind
0
))
(
format
t
" done.]~%"
)
load-size
))
;;; Read-symbol-table reads the symbol table out of the object, making
;;; external symbols available to Lisp, so that they can be used to
;;; link to the C routines.
(
defun
read-symbol-table
(
symstart
symtab-size
strstart
)
(
let
((
end
(
%primitive
sap+
symstart
symtab-size
)))
(
do*
((
se
symstart
(
%primitive
sap+
se
symbol-table-entry-size
))
(
si
(
logior
(
ash
(
%primitive
16bit-system-ref
se
0
)
16
)
(
%primitive
16bit-system-ref
se
1
))
(
logior
(
ash
(
%primitive
16bit-system-ref
se
0
)
16
)
(
%primitive
16bit-system-ref
se
1
)))
(
st
(
%primitive
8bit-system-ref
se
4
)
(
%primitive
8bit-system-ref
se
4
))
(
sv
(
logior
(
ash
(
%primitive
16bit-system-ref
se
4
)
16
)
(
%primitive
16bit-system-ref
se
5
))
(
logior
(
ash
(
%primitive
16bit-system-ref
se
4
)
16
)
(
%primitive
16bit-system-ref
se
5
))))
((
not
(
%primitive
pointer<
se
end
)))
(
declare
(
fixnum
st
))
(
when
(
or
(
=
st
(
logior
n_text
n_ext
))
(
=
st
(
logior
n_data
n_ext
))
(
=
st
(
logior
n_bss
n_ext
)))
(
let*
((
strend
(
%primitive
find-character
strstart
si
(
+
si
512
)
0
)))
(
when
(
null
strend
)
(
error
"Symbol table string didn't terminate."
))
(
let
((
strlen
(
the
fixnum
(
-
(
the
fixnum
strend
)
(
the
fixnum
si
))))
(
offset
0
)
(
code
NIL
)
(
str
NIL
))
(
declare
(
fixnum
strlen
offset
))
(
when
(
eq
(
%primitive
8bit-system-ref
strstart
si
)
(
char-code
#\_
))
(
setq
offset
(
the
fixnum
(
1+
offset
)))
(
when
(
eq
(
%primitive
8bit-system-ref
strstart
(
the
fixnum
(
1+
(
the
fixnum
si
))))
(
char-code
#\.
))
(
setq
code
T
)
(
setq
offset
(
the
fixnum
(
1+
offset
)))))
(
setq
str
(
make-string
(
the
fixnum
(
-
strlen
offset
))))
(
%primitive
byte-blt
strstart
(
the
fixnum
(
+
(
the
fixnum
si
)
offset
))
str
0
strlen
)
(
if
(
let
((
x
(
ash
sv
(
-
(
+
clc::type-shift-16
16
)))))
(
not
(
<=
clc::first-pointer-type
x
clc::last-pointer-type
)))
(
let
((
ste
(
gethash
str
foreign-symbols
))
(
loc
(
int-sap
sv
)))
(
cond
((
null
ste
)
(
setf
(
gethash
str
foreign-symbols
)
(
make-unix-ste
:type
(
if
code
(
logior
n_text
n_ext
)
st
)
:location
(
if
code
nil
loc
))))
(
code
(
setf
(
unix-ste-type
ste
)
(
logior
n_text
n_ext
)))
(
T
(
setf
(
unix-ste-location
ste
)
loc
)))))))))))
;;; Get-code-pointer accepts a simple string which should be the name
;;; of a C routine that has already been loaded into the Lisp core image.
;;; This name should use the correct capitalization of the C name without
;;; the default underscore.
(
defun
get-code-pointer
(
name
)
(
let
((
ste
(
gethash
name
foreign-symbols
)))
(
when
(
null
ste
)
(
error
"There is no foreign function named ~A loaded."
name
))
(
when
(
not
(
eq
(
unix-ste-type
ste
)
(
logior
n_text
n_ext
)))
(
error
"~A is a foreign external variable, not a foreign function."
name
))
(
unix-ste-location
ste
)))
(
let
((
output-file
(
pick-temporary-file-name
))
(
symbol-table-file
(
pick-temporary-file-name
))
(
error-output
(
make-string-output-stream
)))
(
format
t
";;; Running ~A...~%"
linker
)
(
force-output
)
(
let
((
proc
(
ext:run-program
linker
(
list*
(
or
*previous-linked-object-file*
base-file
)
(
format
nil
"~X"
*foreign-segment-free-pointer*
)
output-file
symbol-table-file
(
append
(
if
(
atom
files
)
(
list
files
)
files
)
libraries
))
:env
env
:input
nil
:output
error-output
:error
:output
)))
(
unless
proc
(
error
"Could not run ~S"
linker
))
(
unless
(
zerop
(
ext:process-exit-code
proc
))
(
system:serve-all-events
0
)
(
error
"~S failed:~%~A"
linker
(
get-output-stream-string
error-output
)))
(
load-object-file
output-file
)
(
parse-symbol-table
symbol-table-file
)
(
mach:unix-unlink
symbol-table-file
)
(
let
((
old-file
*previous-linked-object-file*
))
(
setf
*previous-linked-object-file*
output-file
)
(
when
old-file
(
mach:unix-unlink
old-file
)))))
(
format
t
";;; Done.~%"
))
;;; Get-data-pointer is similar to get-code-pointer, except it returns the
;;; address of a foreign global variable.
(
defun
get-data-pointer
(
name
)
(
let
((
ste
(
gethash
name
foreign-symbols
)))
(
when
(
null
ste
)
(
error
"There is no foreign variable named ~A loaded."
name
))
(
when
(
eq
(
unix-ste-type
ste
)
(
logior
n_text
n_ext
))
(
error
"~A is a foreign function, not a foreign variable."
name
))
(
unix-ste-location
ste
)))
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment