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
afcbeab4
Commit
afcbeab4
authored
33 years ago
by
wlott
Browse files
Options
Downloads
Patches
Plain Diff
New-aliens changes.
parent
a952f260
No related branches found
Branches containing commit
No related tags found
Tags containing commit
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
compiler/rt/c-call.lisp
+134
-105
134 additions, 105 deletions
compiler/rt/c-call.lisp
with
134 additions
and
105 deletions
compiler/rt/c-call.lisp
+
134
−
105
View file @
afcbeab4
...
@@ -7,7 +7,7 @@
...
@@ -7,7 +7,7 @@
;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
;;; **********************************************************************
;;; **********************************************************************
;;;
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/c-call.lisp,v 1.
3
199
1
/0
4/21 19:52:56
wlott Exp $
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/c-call.lisp,v 1.
4
199
2
/0
3/09 20:42:20
wlott Exp $
;;;
;;;
;;; This file contains the VOPs and other necessary machine specific support
;;; This file contains the VOPs and other necessary machine specific support
;;; routines for call-out to C.
;;; routines for call-out to C.
...
@@ -19,133 +19,163 @@
...
@@ -19,133 +19,163 @@
(
in-package
"RT"
)
(
in-package
"RT"
)
;;;; Make-call-out-argument-tns and support stuff.
(
defun
c-call-wired-tn
(
primitive-type
sc-name
offset
)
(
defun
c-call-wired-tn
(
primitive-type
sc-name
offset
)
(
make-wired-tn
(
primitive-type-or-lose
primitive-type
)
(
make-wired-tn
(
primitive-type-or-lose
primitive-type
)
(
sc-number-or-lose
sc-name
)
(
sc-number-or-lose
sc-name
)
offset
))
offset
))
(
def-vm-support-routine
make-call-out-nsp-tn
()
(
c-call-wired-tn
'positive-fixnum
'word-pointer-reg
nsp-offset
))
(
defstruct
arg-state
(
stack-frame-size
0
))
(
def-vm-support-routine
make-call-out-argument-tns
(
arg-types
)
(
defun
int-arg
(
state
prim-type
stack-sc
)
(
let
((
nargs
0
))
;; C expects 4 register args and the 5th arg at the top of the stack.
(
collect
((
tns
))
;; We can't put args in registers, because we need those registers
(
dolist
(
type
arg-types
)
;; for something else. So we put them just beyond the end of the
(
multiple-value-bind
;; stack and the trampoline code will move them into place.
(
ptype
reg-sc
stack-sc
)
(
let
((
frame-size
(
arg-state-stack-frame-size
state
)))
(
ecase
(
if
(
consp
type
)
(
car
type
)
type
)
(
setf
(
arg-state-stack-frame-size
state
)
(
1+
frame-size
))
((
unsigned-byte
port
)
(
c-call-wired-tn
prim-type
stack-sc
frame-size
)))
(
values
'unsigned-byte-32
'unsigned-reg
'unsigned-stack
))
(
signed-byte
(
defun
int-result
(
state
prim-type
reg-sc
)
(
values
'signed-byte-32
'signed-reg
'signed-stack
))
(
let
((
reg-num
(
arg-state-stack-frame-size
state
)))
(
system-area-pointer
(
setf
(
arg-state-stack-frame-size
state
)
(
1+
reg-num
))
(
values
'system-area-pointer
'sap-reg
'sap-stack
)))
(
c-call-wired-tn
prim-type
reg-sc
reg-num
)))
;; C expects 4 register args and the 5th arg at the top of the stack.
;; We can't put args in registers, because we need those registers
(
def-alien-type-method
(
integer
:arg-tn
)
(
type
state
)
;; for something else. So we put them just beyond the end of the
(
if
(
alien-integer-type-signed
type
)
;; stack and the trampoline code will move them into place.
(
int-arg
state
'signed-byte-32
'signed-stack
)
(
tns
(
c-call-wired-tn
ptype
stack-sc
nargs
))
(
int-arg
state
'unsigned-byte-32
'unsigned-stack
)))
(
incf
nargs
)))
(
values
(
tns
)
(
def-alien-type-method
(
integer
:result-tn
)
(
type
state
)
(
*
nargs
word-bytes
)))))
(
if
(
alien-integer-type-signed
type
)
(
int-result
state
'signed-byte-32
'signed-reg
)
(
def-vm-support-routine
make-call-out-result-tn
(
type
)
(
int-result
state
'unsigned-byte-32
'unsigned-reg
)))
(
let
((
offset
nl0-offset
))
(
labels
(
def-alien-type-method
(
alien::sap
:arg-tn
)
(
type
state
)
((
frob
(
type
)
(
declare
(
ignore
type
))
(
let
((
name
(
if
(
consp
type
)
(
car
type
)
type
)))
(
int-arg
state
'system-area-pointer
'sap-stack
))
(
prog1
(
ecase
name
(
def-alien-type-method
(
alien::sap
:result-tn
)
(
type
state
)
((
unsigned-byte
port
)
(
declare
(
ignore
type
))
(
c-call-wired-tn
'unsigned-byte-32
'unsigned-reg
offset
))
(
int-result
state
'system-area-pointer
'sap-reg
))
(
signed-byte
(
c-call-wired-tn
'signed-byte-32
'signed-reg
offset
))
(
def-alien-type-method
(
values
:result-tn
)
(
type
state
)
(
system-area-pointer
(
mapcar
#'
(
lambda
(
type
)
(
c-call-wired-tn
'system-area-pointer
'sap-reg
offset
))
(
invoke-alien-type-method
:result-tn
type
state
))
(
values
(
alien-values-type-values
type
)))
(
when
(
consp
type
)
(
mapcar
#'
frob
(
cdr
type
)))))
(
def-vm-support-routine
make-call-out-argument-tns
(
type
)
(
incf
offset
)))))
(
declare
(
type
alien-function-type
type
))
(
frob
type
))))
(
let
((
arg-state
(
make-arg-state
)))
(
collect
((
arg-tns
))
(
deftransform
ext::call-foreign-function
(
dolist
(
arg-type
(
alien-function-type-arg-types
type
))
((
name
return-type
arg-types
&rest
args
)
(
arg-tns
(
invoke-alien-type-method
:arg-tn
arg-type
arg-state
)))
(
string
*
list
&rest
t
))
(
values
(
c-call-wired-tn
'positive-fixnum
'word-pointer-reg
nsp-offset
)
(
assert
(
c::constant-continuation-p
name
))
(
*
(
arg-state-stack-frame-size
arg-state
)
word-bytes
)
(
assert
(
c::constant-continuation-p
return-type
))
(
arg-tns
)
(
assert
(
c::constant-continuation-p
arg-types
))
(
invoke-alien-type-method
(
let
((
name
(
c::continuation-value
name
))
:result-tn
(
return-type
(
c::continuation-value
return-type
))
(
alien-function-type-result-type
type
)
(
arg-types
(
c::continuation-value
arg-types
)))
(
make-arg-state
:frame-size
nl0-offset
))))))
;;;; Deftransforms to convert uses of %alien-funcall into cononical form.
(
deftransform
%alien-funcall
((
function
type
&rest
args
)
(
t
*
&rest
t
))
(
assert
(
c::constant-continuation-p
type
))
(
let*
((
type
(
c::continuation-value
type
))
(
arg-types
(
alien-function-type-arg-types
type
))
(
result-type
(
alien-function-type-result-type
type
)))
(
assert
(
=
(
length
arg-types
)
(
length
args
)))
(
assert
(
=
(
length
arg-types
)
(
length
args
)))
(
if
(
member
'double-float
arg-types
)
(
if
(
some
#'
alien::alien-double-float-type-p
arg-types
)
(
let
((
new-args
nil
)
(
collect
((
new-args
)
(
lambda-vars
)
(
new-arg-types
))
(
lambda-vars
nil
)
(
new-types
nil
))
(
dolist
(
type
arg-types
)
(
dolist
(
type
arg-types
)
(
let
((
arg
(
gensym
)))
(
let
((
arg
(
gensym
)))
(
push
arg
lambda-vars
)
(
lambda-vars
arg
)
(
case
type
(
type
case
type
(
double-float
(
alien::alien-
double-float
-type
(
push
`
(
double-float-high-bits
,
arg
)
new-args
)
(
new-args
`
(
double-float-high-bits
,
arg
))
(
push
'
(
signed-byte
32
)
new-types
)
(
new-args
`
(
double-float-low-bits
,
arg
)
)
(
push
`
(
double-float-low-bits
,
arg
)
new-args
)
(
new-arg-types
(
parse-alien-type
'
(
signed
32
))
)
(
push
'
(
unsigned-byte
32
)
new-types
))
(
new-arg-types
(
parse-alien-type
'
(
unsigned
32
))
))
(
t
(
t
(
push
arg
new-args
)
(
new-args
arg
)
(
push
type
new-types
)))))
(
new-arg-types
type
)))))
`
(
lambda
(
name
return-type
arg-types
,@
(
nreverse
lambda-vars
))
`
(
lambda
(
function
type
,@
(
lambda-vars
))
(
declare
(
ignore
name
return-type
arg-types
))
(
declare
(
ignore
type
))
(
ext::call-foreign-function
,
name
',return-type
(
%alien-funcall
function
',
(
nreverse
new-types
)
',
(
alien::make-alien-function-type
,@
(
nreverse
new-args
))))
:arg-types
(
new-arg-types
)
:result-type
result-type
)
,@
(
new-args
))))
(
c::give-up
))))
(
c::give-up
))))
(
deftransform
ext::call-foreign-function
(
deftransform
%alien-funcall
((
function
type
&rest
args
)
((
name
return-type
arg-types
&rest
args
)
(
*
t
&rest
t
))
(
string
t
*
&rest
t
))
(
assert
(
c::constant-continuation-p
type
))
(
assert
(
c::constant-continuation-p
name
))
(
let*
((
type
(
c::continuation-value
type
))
(
assert
(
c::constant-continuation-p
return-type
))
(
arg-types
(
alien-function-type-arg-types
type
))
(
assert
(
c::constant-continuation-p
arg-types
))
(
result-type
(
alien-function-type-result-type
type
)))
(
let
((
name
(
c::continuation-value
name
))
(
assert
(
=
(
length
arg-types
)
(
length
args
)))
(
return-type
(
c::continuation-value
return-type
))
(
flet
((
make-arg-name-list
()
(
arg-types
(
c::continuation-value
arg-types
))
(
mapcar
#'
(
lambda
(
x
)
(
declare
(
ignore
x
))
(
gensym
))
(
arg-names
(
mapcar
#'
(
lambda
(
x
)
(
declare
(
ignore
x
))
(
gensym
))
args
)))
arg-types
)))
(
case
return-type
(
typecase
result-type
(
double-float
(
alien::alien-double-float-type
`
(
lambda
(
name
return-type
arg-types
,@
arg-names
)
(
let
((
arg-names
(
make-arg-name-list
)))
(
declare
(
ignore
name
return-type
arg-types
))
`
(
lambda
(
function
type
,@
arg-names
)
(
multiple-value-bind
(
declare
(
ignore
type
))
(
hi
lo
)
(
multiple-value-bind
(
ext::call-foreign-function
,
name
(
hi
lo
)
'
(
values
signed-byte
unsigned-byte
)
(
%alien-funcall
function
',arg-types
',
(
parse-alien-type
,@
arg-names
)
`
(
function
(
values
(
signed
32
)
(
make-double-float
hi
lo
))))
(
unsigned
32
))
(
single-float
,@
arg-types
))
`
(
lambda
(
name
return-type
arg-types
,@
arg-names
)
,@
arg-names
)
(
make-single-float
(
make-double-float
hi
lo
)))))
(
ext::call-foreign-function
,
name
'signed-byte
',arg-types
(
alien::alien-single-float-type
,@
arg-names
))))
(
let
((
arg-names
(
make-arg-name-list
)))
(
t
`
(
lambda
(
function
type
,@
arg-names
)
(
c::give-up
)))))
(
declare
(
ignore
type
))
(
make-single-float
(
%alien-function
function
',
(
parse-alien-type
`
(
function
(
signed
32
)
,@
arg-types
))
,@
arg-names
)))))
(
t
(
c::give-up
))))))
;;;; Vops.
(
define-vop
(
foreign-symbol-address
)
(
define-vop
(
foreign-symbol-address
)
(
:translate
foreign-symbol-address
)
(
:policy
:fast-safe
)
(
:args
)
(
:arg-types
(
:constant
simple-string
))
(
:info
foreign-symbol
)
(
:info
foreign-symbol
)
(
:results
(
res
:scs
(
sap-reg
)))
(
:results
(
res
:scs
(
sap-reg
)))
(
:result-types
system-area-pointer
)
(
:generator
2
(
:generator
2
(
inst
cai
res
(
make-fixup
(
concatenate
'simple-string
"_"
foreign-symbol
)
(
inst
cai
res
(
make-fixup
(
concatenate
'simple-string
"_"
foreign-symbol
)
:foreign
))))
:foreign
))))
(
define-vop
(
call-out
)
(
define-vop
(
call-out
)
(
:args
(
args
:more
t
))
(
:args
(
function
:scs
(
sap-reg
)
:target
nl0
)
(
args
:more
t
))
(
:results
(
results
:more
t
))
(
:results
(
results
:more
t
))
(
:ignore
args
results
)
(
:ignore
args
results
)
(
:save-p
t
)
(
:save-p
t
)
(
:info
function
)
(
:info
function
)
(
:temporary
(
:sc
any-reg
:offset
nl0-offset
:to
(
:result
0
))
nl0
)
(
:temporary
(
:sc
any-reg
:offset
nl0-offset
:from
(
:argument
0
)
:to
(
:result
0
))
nl0
)
(
:temporary
(
:sc
any-reg
:offset
lra-offset
)
lra
)
(
:temporary
(
:sc
any-reg
:offset
lra-offset
)
lra
)
(
:temporary
(
:sc
any-reg
:offset
code-offset
)
code
)
(
:temporary
(
:sc
any-reg
:offset
code-offset
)
code
)
(
:temporary
(
:scs
(
sap-reg
)
:to
(
:result
0
))
temp
)
(
:temporary
(
:scs
(
sap-reg
)
:to
(
:result
0
))
temp
)
...
@@ -154,11 +184,10 @@
...
@@ -154,11 +184,10 @@
(
:generator
0
(
:generator
0
(
let
((
lra-label
(
gen-label
))
(
let
((
lra-label
(
gen-label
))
(
cur-nfp
(
current-nfp-tn
vop
)))
(
cur-nfp
(
current-nfp-tn
vop
)))
(
move
nl0
function
)
(
when
cur-nfp
(
when
cur-nfp
(
store-stack-tn
cur-nfp
nfp-save
))
(
store-stack-tn
cur-nfp
nfp-save
))
(
inst
compute-lra-from-code
lra
code
lra-label
)
(
inst
compute-lra-from-code
lra
code
lra-label
)
(
inst
cai
nl0
(
make-fixup
(
concatenate
'simple-string
"_"
function
)
:foreign
))
(
inst
cai
temp
(
make-fixup
"call_into_c"
:foreign
))
(
inst
cai
temp
(
make-fixup
"call_into_c"
:foreign
))
(
inst
b
temp
)
(
inst
b
temp
)
...
...
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