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
External wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Model registry
Operate
Environments
Monitor
Incidents
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
GitLab community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
cmucl
cmucl
Commits
63ee0fd3
Commit
63ee0fd3
authored
Aug 4, 2013
by
Raymond Toy
Browse files
Options
Downloads
Plain Diff
Merged in arm-rtoy-add-macros (pull request
#9
)
Add macros.lisp, based on the sparc version
parents
eb996427
3f2fc5af
Branches
Branches containing commit
Tags
Tags containing commit
No related merge requests found
Changes
2
Show whitespace changes
Inline
Side-by-side
Showing
2 changed files
src/compiler/arm/macros.lisp
+95
-170
95 additions, 170 deletions
src/compiler/arm/macros.lisp
src/compiler/arm/parms.lisp
+40
-0
40 additions, 0 deletions
src/compiler/arm/parms.lisp
with
135 additions
and
170 deletions
src/compiler/arm/macros.lisp
+
95
−
170
View file @
63ee0fd3
...
...
@@ -5,19 +5,15 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(
ext:file-comment
"$Header: src/compiler/
sp
ar
c
/macros.lisp $"
)
"$Header: src/compiler/ar
m
/macros.lisp $"
)
;;;
;;; **********************************************************************
;;;
;;; $Header: src/compiler/sparc/macros.lisp $
;;;
;;; This file contains various useful macros for generating SPARC code.
;;;
;;; Written by William Lott.
;;; This file contains various useful macros for generating ARM code.
;;;
(
in-package
"
SP
AR
C
"
)
(
intl:textdomain
"cmucl-
sp
ar
c
-vm"
)
(
in-package
"AR
M
"
)
(
intl:textdomain
"cmucl-ar
m
-vm"
)
;;; Instruction-like macros.
...
...
@@ -30,53 +26,35 @@
(
inst
move
,
n-dst
,
n-src
))))
;; (loadw object base &optional (offset 0) (lowtag 0) temp)
;; (storew object base &optional (offset 0) (lowtag 0) temp)
;;
;; Load a word at a given address into the register OBJECT. The
;; address of the word is in register BASE, plus an offset given by
;; OFFSET, which is in words. LOWTAG is an adjustment to OFFSET to
;; account for any tag bits used in the BASE descriptor register.
;; Load a word at a given address into the register OBJECT, or store
;; OBJECT at the given address.. The address of the word is in
;; register BASE, plus an offset given by OFFSET, which is in words.
;; LOWTAG is an adjustment to OFFSET to account for any tag bits used
;; in the BASE descriptor register.
;;
;; In some situations, the offset may be so large that it cannot fit
;; into the offset field of the LD instruction (a 13-bit signed
;; quantity). In this situation, the TEMP
non-descriptor register
, if
;; into the offset field of the LD
R(STR)
instruction (a 13-bit signed
;; quantity). In this situation, the TEMP
register (any-reg)
, if
;; supplied, is used to compute the correct offset. If TEMP is not
;; given, the offset is assumed to fit. (TEMP must be a
;; non-descriptor because we store random values into it. If OBJECT
;; were always a non-descriptor, we wouldn't need the TEMP register.)
;; given, the offset is assumed to fit.
;;
;; Samething for storew, except we store OBJECT at the given address.
(
macrolet
((
frob
(
op
inst
shift
)
`
(
defmacro
,
op
(
object
base
&optional
(
offset
0
)
(
lowtag
0
)
temp
)
(
if
temp
(
let
((
offs
(
gensym
)))
`
(
let
((
,
offs
(
-
(
ash
,
offset
,
',shift
)
,
lowtag
)))
(
if
(
typep
,
offs
'
(
signed-byte
13
))
(
inst
,
',inst
,
object
,
base
,
offs
)
(
progn
(
inst
li
,
temp
,
offs
)
(
inst
,
',inst
,
object
,
base
,
temp
)))))
`
(
inst
,
',inst
,
object
,
base
(
-
(
ash
,
offset
,
',shift
)
,
lowtag
))))))
(
frob
loadw
ldn
word-shift
)
#+
(
and
sparc-v9
sparc-v8plus
)
(
frob
loadsw
ldsw
word-shift
)
(
frob
storew
stn
word-shift
))
#+
(
and
sparc-v9
sparc-v8plus
)
(
macrolet
((
frob
(
op
inst
shift
)
((
def-load/store-word
(
op
inst
shift
)
`
(
defmacro
,
op
(
object
base
&optional
(
offset
0
)
(
lowtag
0
)
temp
)
(
if
temp
(
let
((
offs
(
gensym
)))
`
(
let
((
,
offs
(
-
(
ash
,
offset
,
',shift
)
,
lowtag
)))
(
if
(
typep
,
offs
'
(
signed-byte
13
))
(
inst
,
',inst
,
object
,
base
,
offs
)
(
if
(
typep
'
(
signed-byte
13
)
,
offs
)
(
inst
,
',inst
,
object
(
make-ea
,
base
:offset
,
offs
)
)
(
progn
(
inst
li
,
temp
,
offs
)
(
inst
,
',inst
,
object
,
base
,
temp
)))))
`
(
inst
,
',inst
,
object
,
base
(
-
(
ash
,
offset
,
',shift
)
,
lowtag
))))))
(
frob
load
64
ld
x
(
*
2
word-shift
)
)
(
frob
store
64
st
x
(
*
2
word-shift
))
)
(
inst
,
',inst
,
object
(
make-ea
,
base
:offset
,
temp
)))))
)
`
(
inst
,
',inst
,
object
(
make-ea
,
base
:offset
(
-
(
ash
,
offset
,
',shift
)
,
lowtag
))))))
)
(
def-load/store-word
load
w
ld
r
word-shift
)
(
def-load/store-word
store
w
st
r
word-shift
))
(
defmacro
load-symbol
(
reg
symbol
)
`
(
inst
add
,
reg
null-tn
(
static-symbol-offset
,
symbol
)))
...
...
@@ -96,15 +74,17 @@
(
find-package
"VM"
))))
`
(
progn
(
defmacro
,
loader
(
reg
symbol
)
`
(
inst
ldn
,
reg
null-tn
(
+
(
static-symbol-offset
',symbol
)
`
(
inst
ldr
,
reg
(
make-ea
null-tn
:offset
(
+
(
static-symbol-offset
',symbol
)
(
ash
,
',offset
word-shift
)
(
-
other-pointer-type
))))
(
-
other-pointer-type
))))
)
(
defmacro
,
storer
(
reg
symbol
)
`
(
inst
stn
,
reg
null-tn
(
+
(
static-symbol-offset
',symbol
)
`
(
inst
str
,
reg
(
make-ea
null-tn
:offset
(
+
(
static-symbol-offset
',symbol
)
(
ash
,
',offset
word-shift
)
(
-
other-pointer-type
))))))))
(
-
other-pointer-type
))))))))
)
(
frob
value
)
(
frob
function
))
...
...
@@ -116,9 +96,9 @@
(
n-offset
offset
))
(
ecase
(
backend-byte-order
*target-backend*
)
(
:little-endian
`
(
inst
ld
u
b
,
n-target
,
n-source
,
n-offset
))
`
(
inst
ld
r
b
,
n-target
(
make-ea
,
n-source
:offset
,
n-offset
))
)
(
:big-endian
`
(
inst
ld
u
b
,
n-target
,
n-source
(
+
,
n-offset
3
))))))
`
(
inst
ld
r
b
,
n-target
(
make-ea
,
n-source
:offset
(
+
,
n-offset
(
1-
word-bytes
))
))))))
;;; Macros to handle the fact that we cannot use the machine native call and
;;; return instructions.
...
...
@@ -126,18 +106,18 @@
(
defmacro
lisp-jump
(
function
)
"Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
`
(
progn
(
inst
j
,
function
(
move
code-tn
,
function
)
(
inst
add
lip-tn
,
function
(
-
(
ash
function-code-offset
word-shift
)
vm:function-pointer-type
))
(
move
code-tn
,
functio
n
)))
(
inst
bx
lip-t
n
)))
(
defmacro
lisp-return
(
return-pc
&key
(
offset
0
)
(
frob-code
t
))
"Return to RETURN-PC."
`
(
progn
(
inst
j
,
return-pc
(
-
(
*
(
1+
,
offset
)
word-bytes
)
other-pointer-type
))
,
(
if
frob-code
`
(
move
code-tn
,
return-pc
)
'
(
inst
nop
))))
,
(
when
frob-code
`
(
move
code-tn
,
return-pc
))
(
inst
add
lip-tn
,
return-pc
(
-
(
*
(
1+
,
offset
)
word-bytes
)
other-pointer-type
))
(
inst
bx
lip-tn
)))
(
defmacro
emit-return-pc
(
label
)
"Emit a return-pc header word. LABEL is the label to use for this return-pc."
...
...
@@ -154,13 +134,19 @@
;;;
;;; Move a stack TN to a register and vice-versa.
;;;
;;; FIXME: On SPARC, sometimes the offset to the stack TN won't fit in
;;; the offset field of the LD instruction. The same is true on
;;; ARM. For SPARC, there is a dedicated register to use as a temp.
;;; It would be useful on ARM if Load-Stack-TN and Store-Stack-TN took
;;; an optional arg to specify a temp non-descriptor reg that could be
;;; used to allow access to the entire stack.
(
defmacro
load-stack-tn
(
reg
stack
)
`
(
let
((
reg
,
reg
)
(
stack
,
stack
))
(
let
((
offset
(
tn-offset
stack
)))
(
sc-case
stack
((
control-stack
)
(
loadw
reg
cfp-tn
offset
0
gtemp-tn
))))))
(
loadw
reg
cfp-tn
offset
0
))))))
(
defmacro
store-stack-tn
(
stack
reg
)
`
(
let
((
stack
,
stack
)
...
...
@@ -168,7 +154,7 @@
(
let
((
offset
(
tn-offset
stack
)))
(
sc-case
stack
((
control-stack
)
(
storew
reg
cfp-tn
offset
0
gtemp-tn
))))))
(
storew
reg
cfp-tn
offset
0
))))))
;;; MAYBE-LOAD-STACK-TN -- Interface
...
...
@@ -210,86 +196,26 @@
;; We assume we're in a pseudo-atomic so the pseudo-atomic bit is
;; set.
`
(
cond
(
,
stack-p
;; Stack allocation
;;
;; The control stack grows up, so round up CSP to a
;; multiple of 8 (lispobj size). Use that as the
;; allocation pointer. Then add SIZE bytes to the
;; allocation and set CSP to that, so we have the desired
;; space.
;; Make sure the temp-tn is a non-descriptor register!
(
assert
(
and
,
temp-tn
(
sc-is
,
temp-tn
non-descriptor-reg
)))
;; temp-tn is csp-tn rounded up to a multiple of 8 (lispobj size)
(
inst
add
,
temp-tn
csp-tn
vm:lowtag-mask
)
(
inst
andn
,
temp-tn
vm:lowtag-mask
)
;; Set the result to temp-tn, with appropriate lowtag
(
inst
or
,
result-tn
,
temp-tn
,
lowtag
)
;; Allocate the desired space on the stack.
;;
;; FIXME: Can't allocate on stack if SIZE is too large.
;; Need to rearrange this code.
(
inst
add
csp-tn
,
temp-tn
,
size
)
)
;; Stack allocation, not supported
(
error
"Stack allocation not supported"
))
#-
gencgc
(
t
;; Normal allocation to the heap.
(
if
(
logbitp
(
1-
lowtag-bits
)
,
lowtag
)
(
progn
(
inst
or
,
result-tn
alloc-tn
,
lowtag
)
(
inst
add
alloc-tn
,
size
))
(
load-symbol-value
,
temp-tn
lisp::*allocation-pointer*
)
(
inst
orr
,
result-tn
,
temp-tn
,
lowtag
)
(
inst
add
,
temp-tn
,
size
)
(
store-symbol-value
,
temp-tn
lisp::*allocation-pointer*
))
(
progn
(
inst
andn
,
result-tn
alloc-tn
lowtag-mask
)
(
inst
or
,
result-tn
,
lowtag
)
(
inst
add
alloc-tn
,
size
))))
(
load-symbol-value
,
temp-tn
lisp::*allocation-pointer*
)
(
inst
bic
,
result-tn
,
temp-tn
lowtag-mask
)
(
inst
orr
,
result-tn
,
lowtag
)
(
inst
add
,
temp-tn
,
size
)
(
store-symbol-value
,
temp-tn
lisp::*allocation-pointer*
))))
#+
gencgc
(
t
;; See if we can do an inline allocation. The updated
;; free pointer should not point past the end of the
;; current region. If it does, a full alloc needs to be
;; done.
(
load-symbol-value
,
result-tn
*current-region-end-addr*
)
;; Sometimes the size is an known constant, but won't fit in
;; the immediate field of an instruction. Hence we have to
;; do this to get it.
(
cond
((
and
(
tn-p
,
temp-tn
)
(
numberp
,
size
)
(
not
(
typep
,
size
'
(
signed-byte
13
))))
(
inst
li
,
temp-tn
,
size
)
(
inst
add
alloc-tn
,
temp-tn
))
(
t
(
inst
add
alloc-tn
,
size
)))
(
inst
andn
,
temp-tn
alloc-tn
lowtag-mask
)
; Zap PA bits
;; temp-tn points to the new end of region. Did we go
;; past the actual end of the region? If so, we need a
;; full alloc.
(
inst
cmp
,
temp-tn
,
result-tn
)
(
without-scheduling
()
;; NOTE: alloc-tn has been updated to point to the new
;; end. But the allocation routines expect alloc-tn
;; points to original free region. Thus, the allocation
;; trap handler MUST subtract SIZE from alloc-tn before
;; calling the alloc routine. This allows for
;; (slightly) faster code for inline allocation.
;; As above, SIZE might not fit in the immediate field of
;; an instruction. Need to do this complicated thing.
(
cond
((
and
(
tn-p
,
temp-tn
)
(
numberp
,
size
)
(
not
(
typep
,
size
'
(
signed-byte
13
))))
(
inst
li
,
result-tn
,
size
)
(
inst
sub
,
result-tn
,
temp-tn
,
result-tn
))
(
t
(
inst
sub
,
result-tn
,
temp-tn
,
size
)))
(
inst
t
:gt
allocation-trap
))
;; Set lowtag appropriately
(
inst
or
,
result-tn
,
lowtag
))))
(
error
"Gencgc not supported"
))))
(
defmacro
with-fixed-allocation
((
result-tn
temp-tn
type-code
size
&key
(
lowtag
other-pointer-type
)
...
...
@@ -361,8 +287,8 @@
(
progn
(
inst
cmp
reg
test
)
(
if
last
(
inst
b
equal
target
)
(
inst
b
:eq
label
)))
(
inst
b
target
equal
)
(
inst
b
label
:eq
)))
(
let
((
start
(
car
test
))
(
end
(
cdr
test
)))
(
cond
((
and
(
=
start
min
)
(
=
end
max
))
...
...
@@ -373,20 +299,20 @@
((
=
start
min
)
(
inst
cmp
reg
end
)
(
if
last
(
inst
b
less-or-equal
target
)
(
inst
b
:le
label
)))
(
inst
b
target
less-or-equal
)
(
inst
b
label
:le
)))
((
=
end
max
)
(
inst
cmp
reg
start
)
(
if
last
(
inst
b
greater-or-equal
target
)
(
inst
b
:ge
label
)))
(
inst
b
target
greater-or-equal
)
(
inst
b
label
:ge
)))
(
t
(
inst
cmp
reg
start
)
(
inst
b
:lt
(
if
not-p
target
not-target
))
(
inst
b
(
if
not-p
target
not-target
)
:lt
)
(
inst
cmp
reg
end
)
(
if
last
(
inst
b
less-or-equal
target
)
(
inst
b
:le
label
))))))))))
(
inst
b
target
less-or-equal
)
(
inst
b
label
:le
))))))))))
(
nreverse
insts
)))
(
defun
gen-other-immediate-test
(
reg
target
not-target
not-p
values
)
...
...
@@ -425,12 +351,10 @@
(
emit-label
,
fall-through
))))
(
gen-other-immediate-test
temp
target
not-target
not-p
immed
))))
(
when
fixnump
`
((
inst
andcc
zero-tn
,
reg
fixnum-tag-mask
)
`
((
inst
tst
,
reg
fixnum-tag-mask
)
,
(
if
(
or
lowtags
hdrs
)
`
(
inst
b
:eq
,
(
if
not-p
not-target
target
)
#+
sparc-v9
,
(
if
not-p
:pn
:pt
))
`
(
inst
b
,
(
if
not-p
:ne
:eq
)
,
target
#+
sparc-v9
,
(
if
not-p
:pn
:pt
)))))
`
(
inst
b
,
(
if
not-p
not-target
target
)
:eq
)
`
(
inst
b
,
target
,
(
if
not-p
:ne
:eq
)))))
(
when
(
or
lowtags
hdrs
)
`
((
inst
and
,
temp
,
reg
lowtag-mask
)))
(
when
lowtags
...
...
@@ -445,9 +369,7 @@
(
1-
lowtag-limit
)
lowtags
)))
(
when
hdrs
`
((
inst
cmp
,
temp
,
lowtag
)
(
inst
b
:ne
,
(
if
not-p
target
not-target
)
#+
sparc-v9
,
(
if
not-p
:pn
:pt
))
(
inst
nop
)
(
inst
b
,
(
if
not-p
target
not-target
)
:ne
)
(
load-type
,
temp
,
reg
(
-
,
lowtag
))
,@
(
gen-other-immediate-test
temp
target
not-target
not-p
hdrs
))))))
...
...
@@ -530,7 +452,7 @@
`
((
let
((
vop
,
vop
))
(
when
vop
(
note-this-location
vop
:internal-error
)))
(
inst
u
nimp
,
kind
)
(
inst
u
df
,
kind
)
(
with-adjustable-vector
(
,
vector
)
(
write-var-integer
(
error-number-or-lose
',code
)
,
vector
)
,@
(
mapcar
#'
(
lambda
(
tn
)
...
...
@@ -555,8 +477,8 @@
"Cause a continuable error. If the error is continued, execution resumes at
LABEL."
`
(
progn
(
inst
b
,
label
)
,@
(
emit-error-break
vop
cerror-trap
error-code
values
)))
,@
(
emit-error-break
vop
cerror-trap
error-code
values
)
(
inst
b
,
label
)))
(
defmacro
generate-error-code
(
vop
error-code
&rest
values
)
"Generate-Error-Code Error-code Value*
...
...
@@ -586,21 +508,24 @@
;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
;;;
(
defmacro
pseudo-atomic
((
&key
(
extra
0
))
&rest
forms
)
(
defmacro
pseudo-atomic
((
&key
temp-tn
(
extra
0
))
&rest
forms
)
(
declare
(
ignore
extra
))
`
(
progn
;; Set the pseudo-atomic flag
(
let
((
label
(
gensym
"LABEL-"
)))
`
(
let
((
,
label
(
gen-label
)))
;; Set the pseudo-atomic flag, in *pseudo-atomic-atomic*
(
without-scheduling
()
(
inst
or
alloc-tn
pseudo-atomic-value
))
(
load-symbol-value
,
temp-tn
lisp::*pseudo-atomic-atomic*
)
(
inst
or
,
temp-tn
pseudo-atomic-value
)
(
store-symbol-value
,
temp-tn
lisp::*pseudo-atomic-atomic*
))
,@
forms
;; Reset the pseudo-atomic flag
(
without-scheduling
()
;; Remove the pseudo-atomic flag.
(Could do subtraction here,
;; but the disassembler prints some notes based on the add
;; instruction.
)
(
inst
andn
alloc-tn
pseudo-atomic-value
)
;; Check to see if
pseudo-atomic
interrupted
flag is set (bit 0 = 1
)
(
inst
andcc
zero-tn
alloc-tn
pseudo-atomic-interrupted-valu
e
)
;; Remove the pseudo-atomic flag.
(
load-symbol-value
,
temp-tn
lisp::*pseudo-atomic-atomic*
)
(
inst
bic
,
temp-tn
pseudo-atomic-value
)
;; Check to see if pseudo-atomic interrupted flag is set
(
inst
tst
,
temp-tn
pseudo-atomic
-
interrupted
-value
)
(
inst
b
,
label
:n
e
)
;; The C code needs to process this correctly and fixup alloc-tn.
(
inst
t
:ne
pseudo-atomic-trap
)
)))
(
inst
bkpt
pseudo-atomic-trap
)
(
emit-label
,
label
))
)))
This diff is collapsed.
Click to expand it.
src/compiler/arm/parms.lisp
+
40
−
0
View file @
63ee0fd3
...
...
@@ -300,8 +300,17 @@
*binding-stack-pointer*
;; Gc
#-
gencgc
*allocation-pointer*
#-
gencgc
*pseudo-atomic-atomic*
;; Gencgc
;;
#+
gencgc
*current-region-free-pointer*
#+
gencgc
*current-region-end-addr*
#+
gencgc
...
...
@@ -349,3 +358,34 @@
;;; The number of bits per element in the assemblers code vector.
;;;
(
defparameter
*assembly-unit-length*
8
)
(
export
'
(
pseudo-atomic-trap
allocation-trap
pseudo-atomic-value
pseudo-atomic-interrupted-value
))
;;;; Pseudo-atomic trap number.
;;;;
;;;; This is the trap number to use when a pseudo-atomic section has
;;;; been interrupted.
;;;;
;;;; FIXME: Choose an appropriate value once the C code has
;;;; implemented.
(
defconstant
pseudo-atomic-trap
16
)
;;;; Pseudo-atomic flag
;;;;
;;;; This value is added to *pseudo-atomic-atomic* to indicate a
;;;; pseudo-atomic section.
(
defconstant
pseudo-atomic-value
(
ash
1
(
1-
vm::lowtag-bits
)))
;;;; Pseudo-atomic-interrupted-mask
;;;;
;;;; This is a mask used to check if a pseudo-atomic section was
;;;; interrupted. This is indicated by least-significant bit of
;;;; *pseudo-atomic-atomic* being 1.
;;;;
;;;; FIXME: This is based on the sparc port where the pseudo-atomic
;;;; stuff is implemented as bits on the alloc-tn. We don't have an
;;;; alloc-tn on ARM. So should we emulate that using
;;;; *pseudo-atomic-atomic* or use *pseudo-atomic-interrupted* as on
;;;; x86?
(
defconstant
pseudo-atomic-interrupted-value
1
)
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