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
2a9d132a
Commit
2a9d132a
authored
35 years ago
by
ram
Browse files
Options
Downloads
Patches
Plain Diff
Initial version.
parent
8c836e2c
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
+332
-6
332 additions, 6 deletions
compiler/represent.lisp
with
332 additions
and
6 deletions
compiler/represent.lisp
+
332
−
6
View file @
2a9d132a
...
...
@@ -16,14 +16,340 @@
;;;
(
in-package
'c
)
;;; REPRESENTATION-SELECT-1-BLOCK -- Internal
;;;; Error routines:
;;;
(
defun
representation-select-1-block
(
block
)
(
declare
(
type
ir2-block
block
))
)
;;; Problems in the VM definition often show up here, so we try to be as
;;; implementor-friendly as possible.
;;;
;;; GET-OPERAND-INFO -- Interface
;;;
;;; Given a TN ref for a VOP argument or result, return these values:
;;; 1] True if the operand is an argument, false otherwise.
;;; 2] The ordinal position of the operand.
;;; 3] True if the operand is a more operand, false otherwise.
;;; 4] The costs for this operand.
;;; 5] The load-scs vector for this operand (NIL if more-p.)
;;;
(
defun
get-operand-info
(
ref
)
(
declare
(
type
tn-ref
ref
))
(
let*
((
arg-p
(
not
(
tn-ref-write-p
ref
)))
(
vop
(
tn-ref-vop
ref
))
(
info
(
vop-info
vop
)))
(
flet
((
frob
(
refs
costs
restr
load
more-cost
)
(
do
((
refs
refs
(
tn-ref-across
refs
))
(
costs
costs
(
cdr
costs
))
(
load
load
(
cdr
load
))
(
n
0
(
1+
i
)))
((
null
costs
)
(
assert
more-cost
)
(
values
arg-p
(
+
n
(
position-in
#'
tn-ref-across
ref
refs
))
t
more-cost
nil
))
(
when
(
eq
refs
ref
)
(
return
(
values
arg-p
n
nil
(
car
costs
)
(
car
load
)))))))
(
if
arg-p
(
frob
(
vop-args
vop
)
(
vop-info-arg-costs
info
)
(
vop-info-arg-load-scs
info
)
(
vop-info-more-arg-costs
info
))
(
frob
(
vop-results
vop
)
(
vop-info-result-costs
info
)
(
vop-info-result-load-scs
info
)
(
vop-info-more-result-costs
info
))))))
;;; LISTIFY-RESTRICTIONS -- Interface
;;;
;;; Convert a load-costs vector to the list of SCs allowed by the operand
;;; restriction.
;;;
(
defun
listify-restrictions
(
restr
)
(
declare
(
type
sc-vector
restr
))
(
collect
((
res
))
(
dotimes
(
i
sc-number-limit
)
(
when
(
eql
(
svref
restr
i
)
i
)
(
res
(
svref
*sc-numbers*
i
))))
(
res
)))
;;; BAD-COSTS-ERROR -- Internal
;;;
;;; Try to give a helpful error message when Ref has no cost specified for
;;; some SC allowed by the TN's primitive-type.
;;;
(
defun
bad-costs-error
(
ref
)
(
declare
(
type
tn-ref
ref
))
(
let*
((
tn
(
tn-ref-tn
ref
))
(
vop
(
tn-ref-vop
ref
))
(
ptype
(
tn-primitive-type
tn
)))
(
multiple-value-bind
(
arg-p
pos
more-p
costs
load-scs
)
(
get-operand-info
ref
)
(
collect
((
losers
))
(
dolist
(
sc
(
primitive-type-scs
ptype
))
(
unless
(
svref
costs
(
sc-number
sc
))
(
losers
sc
)))
(
unless
(
losers
)
(
error
"Representation selection flamed out for no obvious reason.~@
Try again after recompiling the VM definition."
))
(
error
"~S is not valid as the ~:R ~:[result~;argument~] to the~@
~S VOP, since the TN's primitive type ~S allows SCs:~% ~S~@
~:[which cannot be coerced or loaded into the allowed SCs:~
~% ~S~;~]"
tn
pos
arg-p
(
template-name
info
)
(
primitive-type-name
ptype
)
(
mapcar
#'
sc-name
losers
)
more-p
(
mapcar
#'
sc-name
(
listify-restrictions
load-scs
)))))))
;;; BAD-MOVE-ARG-ERROR -- Internal
;;;
(
defun
bad-move-arg-error
(
val
pass
)
(
declare
(
type
tn
val
pass
))
(
error
"No :MOVE-ARGUMENT VOP defined to move ~S (SC ~S) to
~S (SC ~S.)"
val
(
sc-name
(
tn-sc
val
))
pass
(
sc-name
(
tn-sc
pass
))))
;;; SELECT-TN-REPRESENTATION -- Internal
;;;
;;; Select the best representation for a normal TN.
;;; Return the best representation for a normal TN. SCs is a list of the SC
;;; numbers of the SCs to select from. Costs is a scratch vector.
;;;
(
defun
select-tn-representation
(
tn
scs
costs
)
(
declare
(
type
tn
tn
)
(
type
sc-vector
costs
))
(
dolist
(
scn
scs
)
(
setf
(
svref
costs
scn
)
0
))
(
macrolet
((
scan-refs
(
refs
ops-slot
costs-slot
more-costs-slot
)
`
(
do
((
ref
,
refs
(
tn-ref-next
ref
)))
((
null
ref
))
(
let*
((
vop
(
tn-ref-vop
ref
))
(
info
(
vop-info
vop
)))
(
do
((
cost
(
,
costs-slot
info
)
(
cdr
cost
))
(
op
(
,
ops-slot
vop
)
(
tn-ref-across
op
)))
((
null
cost
)
(
add-costs
(
,
more-costs-slot
info
)))
(
when
(
eq
op
ref
)
(
add-costs
(
car
cost
))
(
return
))))))
(
add-costs
(
cost
)
`
(
let
((
cost
,
cost
))
(
dolist
(
scn
scs
)
(
let
((
res
(
svref
cost
scn
)))
(
unless
res
(
bad-costs-error
ref
))
(
incf
(
svref
costs
scn
)
res
))))))
(
scan-refs
(
tn-reads
tn
)
vop-args
vop-info-arg-costs
vop-info-more-arg-costs
)
(
scan-refs
(
tn-writes
tn
)
vop-results
vop-info-result-costs
vop-info-more-result-costs
))
(
let
((
min
most-positive-fixnum
)
(
min-scn
nil
))
(
dolist
(
scn
scs
)
(
let
((
cost
(
svref
costs
scn
)))
(
when
(
<
cost
min
)
(
setq
min
cost
)
(
setq
min-scs
scn
))))
(
svref
*sc-numbers*
min-scn
)))
;;; NOTE-NUMBER-STACK-TN -- Internal
;;;
;;; Prepare for the possibility of a TN being allocated on the number stack
;;; by allocating a number-FP in all functions that TN is referenced in and in
;;; all the functions in their tail sets. Refs is a TN-Refs list of references
;;; to the TN.
;;;
(
defun
note-number-stack-tn
(
refs
)
(
declare
(
type
(
or
tn-ref
null
)
refs
))
(
do
((
ref
refs
(
tn-ref-next
refs
)))
((
null
ref
))
(
let*
((
lambda
(
block-lambda
(
ir2-block-block
(
vop-block
(
tn-ref-fop
ref
)))))
(
tails
(
lambda-tail-set
lambda
)))
(
flet
((
frob
(
fun
)
(
let
((
env
(
lambda-environment
lambda
))
(
2env
(
environment-info
env
)))
(
unless
(
ir2-environment-number-fp
2env
)
(
setf
(
ir2-environment-number-fp
2env
)
(
make-number-fp-tn
env
))))))
(
frob
lambda
)
(
when
tails
(
dolist
(
fun
(
tail-set-functions
tails
))
(
frob
fun
))))))
(
undefined-value
))
;;; ALLOCATE-OLD-NUMBER-FP-TNS -- Internal
;;;
(
defun
select-tn-representation
(
tn
)
;;; Allocate Old-Number-FP and Old-Number-FP-Pass TNs for all functions in
;;; tail sets that have locations which might be allocated on the number stack.
;;;
(
defun
allocate-old-number-fp-tns
(
component
)
(
dolist
(
fun
(
component-lambdas
component
))
(
let*
((
env
(
lambda-environment
fun
))
(
2env
(
environment-info
env
)))
(
unless
(
ir2-environment-old-number-fp
2env
)
(
let
((
tails
(
lambda-tail-set
fun
)))
(
when
tails
(
let
((
info
(
tail-set-info
tails
)))
(
when
(
eq
(
return-info-kind
info
)
:fixed
)
(
dolist
(
loc
(
return-info-locations
))
(
when
(
sc-number-stack-p
(
tn-sc
loc
))
(
setf
(
ir2-environment-old-number-fp
2env
)
(
make-normal-tn
*any-primitive-type*
))
(
setf
(
ir2-environment-old-number-fp-pass
2env
)
(
make-normal-tn
*any-primitive-type*
))
(
return
))))))))))
(
undefined-value
))
;;; EMIT-COERCE-VOP -- Internal
;;;
;;; Emit a coercion VOP for Op or die trying. SCS is the operand's LOAD-SCS
;;; vector, which we use to determine what SCs the VOP will accept. We pick
;;; any acceptable coerce VOP, since it practice it seems uninteresting to have
;;; more than one applicable.
;;;
;;; 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
;;; SC. If we find such a VOP, then we make a TN having the load SC as the
;;; representation.
;;;
(
defun
emit-coerce-vop
(
op
scs
)
(
declare
(
type
tn-ref
op
)
(
type
sc-vector
scs
))
(
let*
((
op-tn
(
tn-ref-tn
op
))
(
op-sc
(
tn-sc
op-tn
))
(
op-scn
(
sc-number
op-sc
))
(
write-p
(
tn-ref-write-p
op
))
(
vop
(
tn-ref-vop
op
))
(
node
(
vop-node
vop
))
(
block
(
vop-block
vop
)))
(
dotimes
(
i
sc-number-limit
(
bad-costs-error
op
))
(
when
(
eql
(
svref
scs
i
)
i
)
(
let
((
res
(
if
write-p
(
svref
(
sc-move-vops
op-sc
)
i
)
(
svref
(
sc-move-vops
(
svref
*sc-numbers*
i
))
op-scn
))))
(
when
res
(
let
((
temp
(
make-representation-tn
i
)))
(
change-tn-ref-tn
op
temp
)
(
if
write-p
(
emit-move-template
node
block
res
temp
op-tn
vop
)
(
emit-move-template
node
block
res
op-tn
temp
vop
)))
(
return
)))))))
;;; COERCE-VOP-OPERANDS -- Internal
;;;
;;; Scan the operands to VOP and call EMIT-COERCE-VOP on any for which we
;;; can't load the operand.
;;;
(
defun
coerce-vop-operands
(
vop
)
(
declare
(
type
vop
vop
))
(
let
((
info
(
vop-info
vop
)))
(
macrolet
((
scan
(
ops
load-scs
)
`
(
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
))))))
(
scan
(
vop-args
vop
)
(
vop-info-arg-load-scs
info
))
(
scan
(
vop-results
vop
)
(
vop-info-result-load-scs
info
)))))
;;; EMIT-MOVES-AND-COERCIONS -- Internal
;;;
;;; Scan the IR2 looking for move operations that need to be replaced with
;;; special-case VOPs and emitting coercion VOPs for operands of normal VOPs.
;;;
(
defun
emit-moves-and-coercions
(
block
)
(
declare
(
type
ir2-block
block
))
(
do
((
vop
(
ir2-block-start-vop
block
)
(
vop-next
vop
)))
((
null
vop
))
(
let
((
info
(
vop-info
vop
))
(
node
(
vop-node
vop
))
(
block
(
vop-block
vop
)))
(
case
(
vop-info-name
info
)
(
move-arguments
(
let*
((
info-args
(
vop-codegen-info
vop
))
(
fp-tn
(
first
info-args
))
(
nfp-tn
(
second
info-args
))
(
pass-locs
(
third
(
info-args
))))
(
do
((
val
(
vop-args
vop
)
(
tn-ref-across
val
))
(
pass
pass-locs
(
cdr
pass-loc
)))
((
null
val
))
(
let*
((
val-tn
(
tn-ref-tn
val
))
(
pass-tn
(
first
pass
))
(
pass-sc
(
tn-sc
pass-tn
))
(
res
(
svref
(
sc-move-arg-vops
pass-sc
)
(
sc-number
(
tn-sc
val-tn
)))))
(
unless
res
(
bad-move-arg-error
val-tn
pass-tn
))
(
emit-move-arg-template
node
block
res
val-tn
(
if
(
sc-number-stack-p
pass-sc
)
nfp-tn
fp-tn
)
pass-tn
vop
)))))
(
move
(
let
((
x
(
tn-ref-tn
(
vop-args
op
)))
(
y
(
tn-ref-tn
(
vop-results
vop
)))
(
res
(
svref
(
sc-move-vops
(
tn-sc
y
))
(
sc-number
(
tn-sc
x
)))))
(
cond
(
res
(
emit-move-template
node
block
res
x
y
vop
)
(
delete-vop
vop
))
(
t
(
coerce-vop-operands
vop
)))))
(
t
(
coerce-vop-operands
vop
))))))
;;; SELECT-REPRESENTATIONS -- Interface
;;;
;;; Entry to representation selection. First we select the representation
;;; for all normal TNs, setting the TN-SC. If we select a representation that
;;; allows the number stack, then we note this so that the number-FP can be
;;; allocated. Next we allocate old-NFP passing TNs for functions that may
;;; return values on the number stack. Finally, we scan the IR2 looking for
;;; places that we need to insert coercions and representation-specific moves.
;;;
(
defun
select-representations
(
component
)
(
let
((
costs
(
make-array
sc-number-limit
)))
(
do
((
tn
(
ir2-component-normal-tns
(
component-info
component
))
(
tn-next
tn
)))
((
null
tn
))
(
let*
((
scs
(
primitive-type-scs
(
tn-primitive-type
tn
)))
(
sc
(
if
(
rest
scs
)
(
select-tn-representation
tn
scs
costs
)
(
svref
*sc-numbers*
(
first
scs
)))))
(
setf
(
tn-sc
tn
)
sc
)
(
when
(
sc-number-stack-p
tn
)
(
note-number-stack-tn
tn
)))))
(
allocate-old-number-fp-tns
component
)
(
do-ir2-blocks
(
block
component
)
(
emit-moves-and-coercions
block
))
(
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