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
42accb9a
Commit
42accb9a
authored
34 years ago
by
ram
Browse files
Options
Downloads
Patches
Plain Diff
Changed stuff to use the new non-descriptor stuff for move/coerce.
parent
ca2602af
No related branches found
No related tags found
No related merge requests found
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
compiler/old-rt/char.lisp
+58
-41
58 additions, 41 deletions
compiler/old-rt/char.lisp
compiler/old-rt/move.lisp
+58
-140
58 additions, 140 deletions
compiler/old-rt/move.lisp
with
116 additions
and
181 deletions
compiler/old-rt/char.lisp
+
58
−
41
View file @
42accb9a
...
@@ -13,53 +13,71 @@
...
@@ -13,53 +13,71 @@
;;;
;;;
(
in-package
'c
)
(
in-package
'c
)
;;;; Moves and coercions:
;;; Move untagged string-char values.
;;;
(
define-vop
(
string-char-move
)
(
define-vop
(
string-char-move
)
(
:args
(
x
:target
y
(
:args
(
x
:target
y
:scs
(
string-char-reg
)
:scs
(
string-char-reg
)
:load
nil
))
:load
-if
(
not
(
location=
x
y
))
))
(
:results
(
y
:scs
(
string-char-reg
)
(
:results
(
y
:scs
(
string-char-reg
)
:load
nil
))
:load-if
(
not
(
location=
x
y
))))
(
:temporary
(
:scs
(
string-char-reg
)
:type
string-char
:from
:argument
:to
:result
)
temp
)
(
:effects
)
(
:effects
)
(
:affected
)
(
:affected
)
(
:generator
0
(
:generator
0
(
sc-case
x
((
string-char-reg
string-char-stack
immediate-string-char
(
unless
(
location=
x
y
)
descriptor-reg
any-reg
stack
)))
(
inst
lr
y
x
))))
(
sc-case
y
((
string-char-reg
string-char-stack
;;;
descriptor-reg
any-reg
stack
)))
(
define-move-vop
string-char-move
:move
(
string-char-reg
)
(
string-char-reg
))
(
let*
((
x-char
(
sc-is
x
string-char-reg
string-char-stack
immediate-string-char
))
;;; Move untagged string-char arguments/return-values.
(
y-char
(
sc-is
y
string-char-reg
string-char-stack
))
;;;
(
same-rep
(
if
x-char
y-char
(
not
y-char
)))
(
define-vop
(
move-string-char-argument
)
(
src
(
if
(
sc-is
x
stack
string-char-stack
immediate-string-char
)
(
:args
(
x
:target
y
temp
x
))
:scs
(
string-char-reg
))
(
dest
(
if
(
sc-is
y
stack
string-char-stack
)
temp
y
)))
(
fp
:scs
(
descriptor-reg
)
:load-if
(
not
(
sc-is
y
string-char-reg
))))
(
unless
(
and
same-rep
(
location=
x
y
))
(
:results
(
y
))
(
:generator
0
(
unless
(
eq
x
src
)
(
sc-case
y
(
sc-case
x
(
string-char-reg
((
string-char-stack
stack
)
(
unless
(
location=
x
y
)
(
load-stack-tn
src
x
))
(
inst
lr
y
x
)))
(
immediate-string-char
(
string-char-stack
(
loadi
src
(
char-code
(
tn-value
x
))))))
(
storew
x
fp
(
tn-offset
y
))))))
;;;
(
if
same-rep
(
define-move-vop
move-string-char-argument
:move-argument
(
unless
(
location=
src
dest
)
(
string-char-reg
)
(
string-char-reg
))
(
inst
lr
dest
src
))
(
if
x-char
(
inst
oiu
dest
src
(
ash
system:%string-char-type
;;; Move a tagged string char to an untagged representation.
clc::type-shift-16
))
;;;
(
inst
nilz
dest
src
system:%character-code-mask
)))
(
define-vop
(
move-to-string-char
)
(
:args
(
x
:scs
(
any-reg
descriptor-reg
)))
(
unless
(
eq
y
dest
)
(
:results
(
y
:scs
(
string-char-reg
)))
(
store-stack-tn
y
dest
))))))
(
:generator
1
(
inst
nilz
y
x
system:%character-code-mask
)))
(
primitive-type-vop
string-char-move
(
:coerce-to-t
:coerce-from-t
:move
)
;;;
string-char
)
(
define-move-vop
move-to-string-char
:move
(
any-reg
descriptor-reg
)
(
string-char-reg
))
;;; Move an untagged string char to a tagged representation.
;;;
(
define-vop
(
move-from-string-char
)
(
:args
(
x
:scs
(
string-char-reg
)))
(
:results
(
y
:scs
(
any-reg
descriptor-reg
)))
(
:generator
1
(
inst
oiu
y
x
(
ash
system:%string-char-type
clc::type-shift-16
))))
;;;
(
define-move-vop
move-from-string-char
:move
(
string-char-reg
)
(
any-reg
descriptor-reg
))
;;;; Other operations:
(
define-vop
(
char-code
)
(
define-vop
(
char-code
)
(
:args
(
ch
:scs
(
string-char-reg
)
:target
res
))
(
:args
(
ch
:scs
(
string-char-reg
)
:target
res
))
...
@@ -74,7 +92,6 @@
...
@@ -74,7 +92,6 @@
(
define-vop
(
code-char
)
(
define-vop
(
code-char
)
(
:args
(
code
:scs
(
any-reg
descriptor-reg
)
:target
res
))
(
:args
(
code
:scs
(
any-reg
descriptor-reg
)
:target
res
))
(
:results
(
res
:scs
(
string-char-reg
)))
(
:results
(
res
:scs
(
string-char-reg
)))
(
:result-types
string-char
)
(
:translate
code-char
)
(
:translate
code-char
)
(
:policy
:fast-safe
)
(
:policy
:fast-safe
)
(
:generator
0
(
:generator
0
...
...
This diff is collapsed.
Click to expand it.
compiler/old-rt/move.lisp
+
58
−
140
View file @
42accb9a
...
@@ -14,83 +14,62 @@
...
@@ -14,83 +14,62 @@
;;;
;;;
(
in-package
'c
)
(
in-package
'c
)
;;; Load-Constant-TN -- Internal
;;;
;;;; Move functions:
;;; Load the Constant or immediate constant TN X into Y. Temp is a
;;; descriptor register temp or NIL, if none is available. Temp must be
(
define-move-function
(
load-immediate
1
)
(
node
x
y
)
;;; supplied if Y may be in memory. Node is for souce context.
((
short-immediate
unsigned-immediate
immediate
random-immediate
)
;;;
(
any-reg
descriptor-reg
))
(
defun
load-constant-tn
(
x
y
temp
node
)
(
let
((
val
(
tn-value
x
)))
(
declare
(
type
tn
x
y
)
(
type
(
or
tn
null
temp
))
(
type
node
node
))
(
etypecase
val
(
assemble
node
(
integer
(
sc-case
x
(
loadi
y
val
))
((
short-immediate
unsigned-immediate
immediate
random-immediate
(
null
immediate-string-char
)
(
inst
cau
y
zero-tn
clc::nil-16
))
(
let
((
val
(
tn-value
x
))
((
member
t
)
(
dest
(
sc-case
y
(
inst
cau
y
zero-tn
clc::t-16
)))))
((
any-reg
descriptor-reg
string-char-reg
)
y
)
(
stack
temp
))))
(
define-move-function
(
load-string-char
1
)
(
node
x
y
)
(
etypecase
val
((
immediate-string-char
)
(
string-char-reg
))
(
integer
(
loadi
y
(
char-code
(
tn-value
x
))))
(
loadi
dest
val
))
(
null
(
define-move-function
(
load-tagged-string-char
2
)
(
node
x
y
)
(
inst
cau
dest
zero-tn
clc::nil-16
))
((
immediate-string-char
)
(
any-reg
descriptor-reg
))
((
member
t
)
(
loadi
y
(
char-code
(
tn-value
x
)))
(
inst
cau
dest
zero-tn
clc::t-16
))
(
inst
oiu
y
y
(
ash
system:%string-char-type
clc::type-shift-16
)))
(
string-char
(
let
((
code
(
char-code
val
)))
(
define-move-function
(
load-constant
5
)
(
node
x
y
)
(
loadi
dest
code
)
((
constant
)
(
any-reg
descriptor-reg
))
(
unless
(
sc-is
y
string-char-reg
)
(
load-slot
y
env-tn
(
tn-offset
x
)))
(
inst
oiu
dest
dest
(
ash
system:%string-char-type
clc::type-shift-16
))))))
(
define-move-function
(
load-stack
5
)
(
node
x
y
)
(
unless
(
eq
dest
y
)
((
stack
)
(
any-reg
descriptor-reg
)
(
store-stack-tn
y
temp
))))
(
string-char-stack
)
(
string-char-reg
))
(
constant
(
load-stack-tn
y
x
))
(
sc-case
y
((
any-reg
descriptor-reg
)
(
define-move-function
(
store-stack
5
)
(
node
x
y
)
(
load-slot
y
env-tn
(
tn-offset
x
)))
((
any-reg
descriptor-reg
)
(
stack
)
(
stack
(
string-char-reg
)
(
string-char-stack
))
(
load-slot
temp
env-tn
(
tn-offset
x
))
(
store-stack-tn
y
x
))
(
store-stack-tn
y
temp
)))))))
;;;; The Move VOP:
;;;; Move and Move-Argument VOPs:
;;;
;;; The Move VOP is used for doing arbitrary moves when there is no
;;; The Move VOP is used for doing arbitrary moves when there is no
;;; type-specific move/coerce operation.
;;; type-specific move/coerce operation.
;;; We need a register to do a memory-memory move.
;;;
;;;
(
define-vop
(
move
)
(
define-vop
(
move
)
(
:args
(
x
:target
y
(
:args
(
x
:target
y
:scs
(
any-reg
descriptor-reg
)
:scs
(
any-reg
descriptor-reg
)
:load
nil
))
:load
-if
(
not
(
location=
x
y
))
))
(
:results
(
y
:scs
(
any-reg
descriptor-reg
)
(
:results
(
y
:scs
(
any-reg
descriptor-reg
)
:load
nil
))
:load-if
(
not
(
location=
x
y
))))
(
:temporary
(
:scs
(
descriptor-reg
)
:from
:argument
:to
:result
)
temp
)
(
:node-var
node
)
(
:effects
)
(
:effects
)
(
:affected
)
(
:affected
)
(
:generator
0
(
:generator
0
(
unless
(
location=
x
y
)
(
unless
(
location=
x
y
)
(
sc-case
x
(
inst
lr
y
x
))))
((
any-reg
descriptor-reg
)
(
sc-case
y
((
any-reg
descriptor-reg
)
(
inst
lr
y
x
))
(
stack
(
store-stack-tn
y
x
))))
(
stack
(
sc-case
y
((
any-reg
descriptor-reg
)
(
load-stack-tn
y
x
))
(
stack
(
load-stack-tn
temp
x
)
(
store-stack-tn
y
temp
))))
(
t
(
unassemble
(
load-constant-tn
x
y
temp
node
)))))))
;;; Make Move the check VOP for T so that type check generation doesn't think
;;; Make Move the check VOP for T so that type check generation doesn't think
...
@@ -99,84 +78,23 @@
...
@@ -99,84 +78,23 @@
;;;
;;;
(
primitive-type-vop
move
(
:check
)
t
)
(
primitive-type-vop
move
(
:check
)
t
)
;;;; ILLEGAL-MOVE
;;; This VOP is emitted when we attempt to do a move between incompatible
;;; The Move-Argument VOP is used for moving descriptor values into another
;;; primitive types. We signal an error, and ignore the result (which is
;;; frame for argument or known value passing.
;;; specified only to terminate its lifetime.)
;;;
;;;
(
define-vop
(
illegal-move
three-arg-miscop
)
(
define-vop
(
move-argument
)
(
:args
(
x
:scs
(
any-reg
descriptor-reg
)
:target
a1
)
(
:args
(
x
:target
y
(
y-type
:scs
(
any-reg
descriptor-reg
)
:target
a2
))
:scs
(
any-reg
descriptor-reg
))
(
:variant-vars
)
(
fp
:scs
(
descriptor-reg
)
(
:ignore
r
a3
nl0
nl1
misc-pc
)
:load-if
(
not
(
sc-is
y
any-reg
descriptor-reg
))))
(
:generator
666
(
loadi
a0
clc::error-object-not-type
)
(
unless
(
location=
x
a1
)
(
inst
lr
a1
x
))
(
unless
(
location=
y-type
a2
)
(
inst
lr
a2
y-type
))
(
inst
miscop
'clc::error2
)
(
note-this-location
vop
:internal-error
)))
;;;; Operand loading and saving:
;;;
;;; These are the VOPs used for loading or saving Load-TNs. They cannot
;;; allocate any temporaries since packing has already been done by the time
;;; that these VOPs are emitted. It can be assumed that the loaded (saved) TN
;;; is free before (after) the load (save) (so may be used as a temporary.)
;;;
(
define-vop
(
load-operand
)
(
:args
(
x
))
(
:results
(
y
))
(
:node-var
node
)
(
:generator
5
(
sc-case
x
(
stack
(
sc-case
y
((
any-reg
descriptor-reg
)
(
load-stack-tn
y
x
))
(
string-char-reg
(
load-stack-tn
y
x
)
(
inst
nilz
y
y
system:%character-code-mask
))))
(
string-char-stack
(
sc-case
y
(
string-char-reg
(
load-stack-tn
y
x
))))
(
t
(
unassemble
(
load-constant-tn
x
y
nil
node
))))))
(
define-vop
(
store-operand
)
(
:args
(
x
))
(
:results
(
y
))
(
:results
(
y
))
(
:generator
5
(
:generator
0
(
sc-case
y
(
sc-case
y
((
any-reg
descriptor-reg
)
(
unless
(
location=
x
y
)
(
inst
lr
y
x
)))
(
stack
(
stack
(
sc-case
x
(
storew
x
fp
(
tn-offset
y
))))))
((
any-reg
descriptor-reg
)
;;;
(
store-stack-tn
y
x
))
(
define-move-vop
move-argument
:move-argument
(
string-char-reg
(
any-reg
descriptor-reg
)
(
any-reg
descriptor-reg
))
(
inst
oiu
x
x
(
ash
system:%string-char-type
clc::type-shift-16
))
(
store-stack-tn
y
x
))))
(
string-char-stack
(
sc-case
x
(
string-char-reg
(
store-stack-tn
y
x
)))))))
;;;; Register saving and restoring VOPs.
(
define-vop
(
save-reg
)
(
:args
(
reg
))
(
:results
(
stack
))
(
:generator
5
(
store-stack-tn
stack
reg
)))
(
define-vop
(
restore-reg
)
(
:args
(
stack
))
(
:results
(
reg
))
(
:generator
5
(
load-stack-tn
reg
stack
)))
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