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
d1f88027
"README.md" did not exist on "49c59321a22fef0700a774e972017cb4f90477a4"
Commit
d1f88027
authored
35 years ago
by
ram
Browse files
Options
Downloads
Patches
Plain Diff
Added code to any emit coercion VOPs before the move-argument VOPs in a call
parent
ee8f462d
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
compiler/represent.lisp
+55
-34
55 additions, 34 deletions
compiler/represent.lisp
with
55 additions
and
34 deletions
compiler/represent.lisp
+
55
−
34
View file @
d1f88027
...
@@ -254,10 +254,10 @@
...
@@ -254,10 +254,10 @@
;;; EMIT-COERCE-VOP -- Internal
;;; EMIT-COERCE-VOP -- Internal
;;;
;;;
;;; Emit a coercion VOP for Op
or die trying. SCS is the operand's LOAD-
SCS
;;; Emit a coercion VOP for Op
Before the specifed VOP or die trying.
SCS
;;; vector, which we use to determine what SCs the
VOP will accept. We pick
;;;
is the operand's LOAD-SCS
vector, which we use to determine what SCs the
;;; any acceptable coerce VOP, since it practice it
seems uninteresting to have
;;;
VOP will accept. We pick
any acceptable coerce VOP, since it practice it
;;; more than one applicable.
;;;
seems uninteresting to have
more than one applicable.
;;;
;;;
;;; What we do is look at each SC allowed by the operand restriction, and
;;; What we do is look at each SC allowed by the operand restriction, and
;;; see if there is a move VOP which moves between the operand's SC and load
;;; see if there is a move VOP which moves between the operand's SC and load
...
@@ -267,8 +267,8 @@
...
@@ -267,8 +267,8 @@
;;; If the TN is an unused result TN, then we don't actually emit the move;
;;; If the TN is an unused result TN, then we don't actually emit the move;
;;; we just change to the right kind of TN.
;;; we just change to the right kind of TN.
;;;
;;;
(
defun
emit-coerce-vop
(
op
scs
)
(
defun
emit-coerce-vop
(
op
scs
before
)
(
declare
(
type
tn-ref
op
)
(
type
sc-vector
scs
))
(
declare
(
type
tn-ref
op
)
(
type
sc-vector
scs
)
(
type
(
or
vop
null
)
before
)
)
(
let*
((
op-tn
(
tn-ref-tn
op
))
(
let*
((
op-tn
(
tn-ref-tn
op
))
(
op-sc
(
tn-sc
op-tn
))
(
op-sc
(
tn-sc
op-tn
))
(
op-scn
(
sc-number
op-sc
))
(
op-scn
(
sc-number
op-sc
))
...
@@ -287,34 +287,49 @@
...
@@ -287,34 +287,49 @@
(
change-tn-ref-tn
op
temp
)
(
change-tn-ref-tn
op
temp
)
(
cond
(
cond
((
not
write-p
)
((
not
write-p
)
(
emit-move-template
node
block
res
op-tn
temp
vop
))
(
emit-move-template
node
block
res
op-tn
temp
before
))
((
null
(
tn-reads
op-tn
)))
((
null
(
tn-reads
op-tn
)))
(
t
(
t
(
emit-move-template
node
block
res
temp
op-tn
(
vop-next
vop
)
))))
(
emit-move-template
node
block
res
temp
op-tn
before
))))
(
return
)))))))
(
return
)))))))
;;; COERCE-SOME-OPERANDS -- Internal
;;;
;;; Scan some operands and call EMIT-COERCE-VOP on any for which we can't
;;; load the operand. The coerce VOP is inserted Before the specified VOP.
;;;
(
proclaim
'
(
inline
coerce-some-operands
))
(
defun
coerce-some-operands
(
ops
load-scs
before
)
(
declare
(
type
(
or
tn-ref
null
)
ops
)
(
list
load-scs
)
(
type
(
or
vop
null
)
before
))
(
do
((
op
ops
(
tn-ref-across
op
))
(
scs
load-scs
(
cdr
scs
)))
((
null
scs
))
(
unless
(
svref
(
car
scs
)
(
sc-number
(
tn-sc
(
tn-ref-tn
op
))))
(
emit-coerce-vop
op
(
car
scs
)
before
)))
(
undefined-value
))
;;; COERCE-VOP-OPERANDS -- Internal
;;; COERCE-VOP-OPERANDS -- Internal
;;;
;;;
;;; Scan the operands to VOP and call EMIT-COERCE-VOP on any for which we
;;; Emit coerce VOPs for the args and results, as needed.
;;; can't load the operand.
;;;
;;;
(
defun
coerce-vop-operands
(
vop
)
(
defun
coerce-vop-operands
(
vop
)
(
declare
(
type
vop
vop
))
(
declare
(
type
vop
vop
))
(
let
((
info
(
vop-info
vop
)))
(
let
((
info
(
vop-info
vop
)))
(
macrolet
((
scan
(
ops
load-scs
)
(
coerce-some-operands
(
vop-args
vop
)
(
vop-info-arg-load-scs
info
)
vop
)
`
(
do
((
op
,
ops
(
tn-ref-across
op
))
(
coerce-some-operands
(
vop-results
vop
)
(
vop-info-result-load-scs
info
)
(
scs
,
load-scs
(
cdr
scs
)))
(
vop-next
vop
))))
((
null
scs
))
(
unless
(
svref
(
car
scs
)
(
sc-number
(
tn-sc
(
tn-ref-tn
op
))))
(
emit-coerce-vop
op
(
car
scs
))))))
(
scan
(
vop-args
vop
)
(
vop-info-arg-load-scs
info
))
(
scan
(
vop-results
vop
)
(
vop-info-result-load-scs
info
)))))
;;; EMIT-ARG-MOVES -- Internal
;;; EMIT-ARG-MOVES -- Internal
;;;
;;;
;;; Iterate over the more operands to a call VOP, emitting move-arg VOPs and
;;; any necessary coercions. We determine which FP to use by looking at the
;;; MOVE-ARGS annotation.
;;;
(
defun
emit-arg-moves
(
vop
)
(
defun
emit-arg-moves
(
vop
)
(
let*
((
info
(
vop-info
vop
))
(
let*
((
info
(
vop-info
vop
))
(
node
(
vop-node
vop
))
(
node
(
vop-node
vop
))
...
@@ -325,7 +340,8 @@
...
@@ -325,7 +340,8 @@
(
nfp-tn
(
if
(
eq
how
:local-call
)
(
nfp-tn
(
if
(
eq
how
:local-call
)
(
tn-ref-tn
(
tn-ref-across
args
))
(
tn-ref-tn
(
tn-ref-across
args
))
nil
))
nil
))
(
pass-locs
(
first
(
vop-codegen-info
vop
))))
(
pass-locs
(
first
(
vop-codegen-info
vop
)))
(
prev
(
vop-prev
vop
)))
(
do
((
val
(
do
((
arg
args
(
tn-ref-across
arg
))
(
do
((
val
(
do
((
arg
args
(
tn-ref-across
arg
))
(
req
(
template-arg-types
info
)
(
cdr
req
)))
(
req
(
template-arg-types
info
)
(
cdr
req
)))
((
null
req
)
arg
))
((
null
req
)
arg
))
...
@@ -340,20 +356,25 @@
...
@@ -340,20 +356,25 @@
(
sc-number
(
tn-sc
val-tn
)))))
(
sc-number
(
tn-sc
val-tn
)))))
(
unless
res
(
unless
res
(
bad-move-arg-error
val-tn
pass-tn
))
(
bad-move-arg-error
val-tn
pass-tn
))
(
let
((
this-fp
(
change-tn-ref-tn
val
pass-tn
)
(
cond
((
not
(
sc-number-stack-p
pass-sc
))
fp-tn
)
(
let*
((
this-fp
(
nfp-tn
)
(
cond
((
not
(
sc-number-stack-p
pass-sc
))
fp-tn
)
(
t
(
nfp-tn
)
(
assert
(
eq
how
:known-return
))
(
t
(
setq
nfp-tn
(
assert
(
eq
how
:known-return
))
(
make-representation-tn
(
setq
nfp-tn
(
first
(
primitive-type-scs
(
make-representation-tn
*any-primitive-type*
))))
(
first
(
primitive-type-scs
(
emit-context-template
node
block
nfp-tn
vop
)
*any-primitive-type*
))))
nfp-tn
))))
(
emit-context-template
node
block
nfp-tn
vop
)
(
emit-move-arg-template
node
block
res
val-tn
this-fp
pass-tn
vop
)))))
nfp-tn
)))
(
new
(
emit-move-arg-template
node
block
res
val-tn
this-fp
pass-tn
vop
)))
(
coerce-some-operands
(
vop-args
new
)
(
vop-info-arg-load-scs
res
)
(
if
prev
(
vop-next
prev
)
(
ir2-block-start-vop
block
)))))))
(
undefined-value
))
(
undefined-value
))
...
...
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