Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
cmucl
cmucl
Commits
5c9837fd
Commit
5c9837fd
authored
Dec 16, 2016
by
Raymond Toy
Browse files
Remove sparc64 stuff so we can do this on a branch.
parent
0f4c649a
Changes
33
Expand all
Hide whitespace changes
Inline
Side-by-side
src/assembly/sparc64/alloc.lisp
deleted
100644 → 0
View file @
0f4c649a
;;; -*- Package: SPARC -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(
ext:file-comment
"$Header: src/assembly/sparc/alloc.lisp $"
)
;;;
;;; **********************************************************************
;;;
;;; Stuff to handle allocating simple objects.
;;;
;;; Written by William Lott.
;;;
(
in-package
"SPARC"
)
;;; But we do everything inline now that we have a better pseudo-atomic.
src/assembly/sparc64/arith.lisp
deleted
100644 → 0
View file @
0f4c649a
;;; -*- Package: SPARC -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(
ext:file-comment
"$Header: src/assembly/sparc/arith.lisp $"
)
;;;
;;; **********************************************************************
;;;
;;; Stuff to handle simple cases for generic arithmetic.
;;;
;;; Written by William Lott.
;;;
(
in-package
"SPARC"
)
;;;; Addition and subtraction.
(
define-assembly-routine
(
generic-+
(
:cost
10
)
(
:return-style
:full-call
)
(
:translate
+
)
(
:policy
:safe
)
(
:save-p
t
))
((
:arg
x
(
descriptor-reg
any-reg
)
a0-offset
)
(
:arg
y
(
descriptor-reg
any-reg
)
a1-offset
)
(
:res
res
(
descriptor-reg
any-reg
)
a0-offset
)
(
:temp
temp
non-descriptor-reg
nl0-offset
)
(
:temp
temp2
non-descriptor-reg
nl1-offset
)
(
:temp
lra
descriptor-reg
lra-offset
)
(
:temp
nargs
any-reg
nargs-offset
)
(
:temp
ocfp
any-reg
ocfp-offset
))
(
inst
andcc
zero-tn
x
fixnum-tag-mask
)
(
inst
b
:ne
DO-STATIC-FUN
)
(
inst
andcc
zero-tn
y
fixnum-tag-mask
)
(
inst
b
:ne
DO-STATIC-FUN
)
(
inst
nop
)
(
inst
addcc
temp
x
y
)
(
inst
b
:vc
done
)
(
inst
nop
)
(
inst
sra
temp
x
fixnum-tag-bits
)
(
inst
sra
temp2
y
fixnum-tag-bits
)
(
inst
add
temp2
temp
)
(
with-fixed-allocation
(
res
temp
bignum-type
(
1+
bignum-digits-offset
))
(
storew
temp2
res
bignum-digits-offset
other-pointer-type
))
(
lisp-return
lra
:offset
2
)
DO-STATIC-FUN
(
inst
ld
code-tn
null-tn
(
static-function-offset
'two-arg-+
))
(
inst
li
nargs
(
fixnumize
2
))
(
inst
move
ocfp
cfp-tn
)
(
inst
j
code-tn
(
-
(
*
function-code-offset
word-bytes
)
function-pointer-type
))
(
inst
move
cfp-tn
csp-tn
)
DONE
(
move
res
temp
))
(
define-assembly-routine
(
generic--
(
:cost
10
)
(
:return-style
:full-call
)
(
:translate
-
)
(
:policy
:safe
)
(
:save-p
t
))
((
:arg
x
(
descriptor-reg
any-reg
)
a0-offset
)
(
:arg
y
(
descriptor-reg
any-reg
)
a1-offset
)
(
:res
res
(
descriptor-reg
any-reg
)
a0-offset
)
(
:temp
temp
non-descriptor-reg
nl0-offset
)
(
:temp
temp2
non-descriptor-reg
nl1-offset
)
(
:temp
lra
descriptor-reg
lra-offset
)
(
:temp
nargs
any-reg
nargs-offset
)
(
:temp
ocfp
any-reg
ocfp-offset
))
(
inst
andcc
zero-tn
x
fixnum-tag-mask
)
(
inst
b
:ne
DO-STATIC-FUN
)
(
inst
andcc
zero-tn
y
fixnum-tag-mask
)
(
inst
b
:ne
DO-STATIC-FUN
)
(
inst
nop
)
(
inst
subcc
temp
x
y
)
(
inst
b
:vc
done
)
(
inst
nop
)
(
inst
sra
temp
x
fixnum-tag-bits
)
(
inst
sra
temp2
y
fixnum-tag-bits
)
(
inst
sub
temp2
temp
temp2
)
(
with-fixed-allocation
(
res
temp
bignum-type
(
1+
bignum-digits-offset
))
(
storew
temp2
res
bignum-digits-offset
other-pointer-type
))
(
lisp-return
lra
:offset
2
)
DO-STATIC-FUN
(
inst
ld
code-tn
null-tn
(
static-function-offset
'two-arg--
))
(
inst
li
nargs
(
fixnumize
2
))
(
inst
move
ocfp
cfp-tn
)
(
inst
j
code-tn
(
-
(
*
function-code-offset
word-bytes
)
function-pointer-type
))
(
inst
move
cfp-tn
csp-tn
)
DONE
(
move
res
temp
))
;;;; Multiplication
(
define-assembly-routine
(
generic-*
(
:cost
50
)
(
:return-style
:full-call
)
(
:translate
*
)
(
:policy
:safe
)
(
:save-p
t
))
((
:arg
x
(
descriptor-reg
any-reg
)
a0-offset
)
(
:arg
y
(
descriptor-reg
any-reg
)
a1-offset
)
(
:res
res
(
descriptor-reg
any-reg
)
a0-offset
)
(
:temp
temp
non-descriptor-reg
nl0-offset
)
(
:temp
lo
non-descriptor-reg
nl1-offset
)
(
:temp
hi
non-descriptor-reg
nl2-offset
)
(
:temp
lra
descriptor-reg
lra-offset
)
(
:temp
nargs
any-reg
nargs-offset
)
(
:temp
ocfp
any-reg
ocfp-offset
))
;; If either arg is not a fixnum, call the static function.
(
inst
andcc
zero-tn
x
fixnum-tag-mask
)
(
inst
b
:ne
DO-STATIC-FUN
)
(
inst
andcc
zero-tn
y
fixnum-tag-mask
)
(
inst
b
:ne
DO-STATIC-FUN
)
(
inst
nop
)
;; Remove the tag from one arg so that the result will have the correct
;; fixnum tag.
(
inst
sra
temp
x
fixnum-tag-bits
)
;; Compute the produce temp * y and return the double-word product
;; in hi:lo.
(
cond
((
backend-featurep
:sparc-64
)
;; Sign extend y to a full 64-bits. temp was already
;; sign-extended by the sra instruction above.
(
inst
sra
y
0
)
(
inst
mulx
hi
temp
y
)
(
inst
move
lo
hi
)
(
inst
srax
hi
32
))
((
or
(
backend-featurep
:sparc-v8
)
(
backend-featurep
:sparc-v9
))
(
inst
smul
lo
temp
y
)
(
inst
rdy
hi
))
(
t
(
let
((
MULTIPLIER-POSITIVE
(
gen-label
)))
(
inst
wry
temp
)
(
inst
andcc
hi
zero-tn
)
(
inst
nop
)
(
inst
nop
)
(
dotimes
(
i
32
)
(
inst
mulscc
hi
y
))
(
inst
mulscc
hi
zero-tn
)
(
inst
cmp
x
)
(
inst
b
:ge
MULTIPLIER-POSITIVE
)
(
inst
nop
)
(
inst
sub
hi
y
)
(
emit-label
MULTIPLIER-POSITIVE
)
(
inst
rdy
lo
))))
;; Check to see if the result will fit in a fixnum. (I.e. the high word
;; is just 32 copies of the sign bit of the low word).
(
inst
sra
temp
lo
31
)
(
inst
xorcc
temp
hi
)
(
inst
b
:eq
LOW-FITS-IN-FIXNUM
)
;; Shift the double word hi:lo down two bits to get rid of the fixnum tag.
(
inst
sll
temp
hi
30
)
(
inst
srl
lo
fixnum-tag-bits
)
(
inst
or
lo
temp
)
(
inst
sra
hi
fixnum-tag-bits
)
;; Allocate a BIGNUM for the result. We always allocate 2 words for
;; the bignum result, even if we only need one. The copying GC will
;; take care of the extra word if it isn't needed.
(
with-fixed-allocation
(
res
temp
bignum-type
(
+
2
bignum-digits-offset
))
(
let
((
one-word
(
gen-label
)))
;; We start out assuming that we need one word. Is that correct?
(
inst
sra
temp
lo
31
)
(
inst
xorcc
temp
hi
)
(
inst
b
:eq
one-word
)
(
inst
li
temp
(
logior
(
ash
1
type-bits
)
bignum-type
))
;; Need 2 words. Set the header appropriately, and save the
;; high and low parts.
(
inst
li
temp
(
logior
(
ash
2
type-bits
)
bignum-type
))
(
storew
hi
res
(
1+
bignum-digits-offset
)
other-pointer-type
)
(
emit-label
one-word
)
(
storew
temp
res
0
other-pointer-type
)
(
storew
lo
res
bignum-digits-offset
other-pointer-type
)))
;; Out of here
(
lisp-return
lra
:offset
2
)
DO-STATIC-FUN
(
inst
ld
code-tn
null-tn
(
static-function-offset
'two-arg-*
))
(
inst
li
nargs
(
fixnumize
2
))
(
inst
move
ocfp
cfp-tn
)
(
inst
j
code-tn
(
-
(
*
function-code-offset
word-bytes
)
function-pointer-type
))
(
inst
move
cfp-tn
csp-tn
)
LOW-FITS-IN-FIXNUM
(
move
res
lo
))
;;;; Comparison
(
macrolet
((
define-cond-assem-rtn
(
name
translate
static-fn
cmp
)
`
(
define-assembly-routine
(
,
name
(
:cost
10
)
(
:return-style
:full-call
)
(
:policy
:safe
)
(
:translate
,
translate
)
(
:save-p
t
))
((
:arg
x
(
descriptor-reg
any-reg
)
a0-offset
)
(
:arg
y
(
descriptor-reg
any-reg
)
a1-offset
)
(
:res
res
descriptor-reg
a0-offset
)
(
:temp
nargs
any-reg
nargs-offset
)
(
:temp
ocfp
any-reg
ocfp-offset
))
(
inst
andcc
zero-tn
x
fixnum-tag-mask
)
(
inst
b
:ne
DO-STATIC-FN
)
(
inst
andcc
zero-tn
y
fixnum-tag-mask
)
(
inst
b
:eq
DO-COMPARE
)
(
inst
cmp
x
y
)
DO-STATIC-FN
(
inst
ld
code-tn
null-tn
(
static-function-offset
',static-fn
))
(
inst
li
nargs
(
fixnumize
2
))
(
inst
move
ocfp
cfp-tn
)
(
inst
j
code-tn
(
-
(
*
function-code-offset
word-bytes
)
function-pointer-type
))
(
inst
move
cfp-tn
csp-tn
)
DO-COMPARE
(
inst
b
,
cmp
done
)
(
load-symbol
res
t
)
(
inst
move
res
null-tn
)
DONE
)))
(
define-cond-assem-rtn
generic-<
<
two-arg-<
:lt
)
(
define-cond-assem-rtn
generic-<=
<=
two-arg-<=
:le
)
(
define-cond-assem-rtn
generic->
>
two-arg->
:gt
)
(
define-cond-assem-rtn
generic->=
>=
two-arg->=
:ge
))
(
define-assembly-routine
(
generic-eql
(
:cost
10
)
(
:return-style
:full-call
)
(
:policy
:safe
)
(
:translate
eql
)
(
:save-p
t
))
((
:arg
x
(
descriptor-reg
any-reg
)
a0-offset
)
(
:arg
y
(
descriptor-reg
any-reg
)
a1-offset
)
(
:res
res
descriptor-reg
a0-offset
)
(
:temp
lra
descriptor-reg
lra-offset
)
(
:temp
nargs
any-reg
nargs-offset
)
(
:temp
ocfp
any-reg
ocfp-offset
))
(
inst
cmp
x
y
)
(
inst
b
:eq
RETURN-T
)
(
inst
andcc
zero-tn
x
fixnum-tag-mask
)
(
inst
b
:eq
RETURN-NIL
)
(
inst
andcc
zero-tn
y
fixnum-tag-mask
)
(
inst
b
:ne
DO-STATIC-FN
)
(
inst
nop
)
RETURN-NIL
(
inst
move
res
null-tn
)
(
lisp-return
lra
:offset
2
)
DO-STATIC-FN
(
inst
ld
code-tn
null-tn
(
static-function-offset
'eql
))
(
inst
li
nargs
(
fixnumize
2
))
(
inst
move
ocfp
cfp-tn
)
(
inst
j
code-tn
(
-
(
*
function-code-offset
word-bytes
)
function-pointer-type
))
(
inst
move
cfp-tn
csp-tn
)
RETURN-T
(
load-symbol
res
t
))
(
define-assembly-routine
(
generic-=
(
:cost
10
)
(
:return-style
:full-call
)
(
:policy
:safe
)
(
:translate
=
)
(
:save-p
t
))
((
:arg
x
(
descriptor-reg
any-reg
)
a0-offset
)
(
:arg
y
(
descriptor-reg
any-reg
)
a1-offset
)
(
:res
res
descriptor-reg
a0-offset
)
(
:temp
lra
descriptor-reg
lra-offset
)
(
:temp
nargs
any-reg
nargs-offset
)
(
:temp
ocfp
any-reg
ocfp-offset
))
(
inst
andcc
zero-tn
x
fixnum-tag-mask
)
(
inst
b
:ne
DO-STATIC-FN
)
(
inst
andcc
zero-tn
y
fixnum-tag-mask
)
(
inst
b
:ne
DO-STATIC-FN
)
(
inst
cmp
x
y
)
(
inst
b
:eq
RETURN-T
)
(
inst
nop
)
(
inst
move
res
null-tn
)
(
lisp-return
lra
:offset
2
)
DO-STATIC-FN
(
inst
ld
code-tn
null-tn
(
static-function-offset
'two-arg-=
))
(
inst
li
nargs
(
fixnumize
2
))
(
inst
move
ocfp
cfp-tn
)
(
inst
j
code-tn
(
-
(
*
function-code-offset
word-bytes
)
function-pointer-type
))
(
inst
move
cfp-tn
csp-tn
)
RETURN-T
(
load-symbol
res
t
))
(
define-assembly-routine
(
generic-/=
(
:cost
10
)
(
:return-style
:full-call
)
(
:policy
:safe
)
(
:translate
/=
)
(
:save-p
t
))
((
:arg
x
(
descriptor-reg
any-reg
)
a0-offset
)
(
:arg
y
(
descriptor-reg
any-reg
)
a1-offset
)
(
:res
res
descriptor-reg
a0-offset
)
(
:temp
lra
descriptor-reg
lra-offset
)
(
:temp
nargs
any-reg
nargs-offset
)
(
:temp
ocfp
any-reg
ocfp-offset
))
(
inst
cmp
x
y
)
(
inst
b
:eq
RETURN-NIL
)
(
inst
andcc
zero-tn
x
fixnum-tag-mask
)
(
inst
b
:ne
DO-STATIC-FN
)
(
inst
andcc
zero-tn
y
fixnum-tag-mask
)
(
inst
b
:ne
DO-STATIC-FN
)
(
inst
nop
)
(
load-symbol
res
t
)
(
lisp-return
lra
:offset
2
)
DO-STATIC-FN
(
inst
ld
code-tn
null-tn
(
static-function-offset
'two-arg-=
))
(
inst
li
nargs
(
fixnumize
2
))
(
inst
move
ocfp
cfp-tn
)
(
inst
j
code-tn
(
-
(
*
function-code-offset
word-bytes
)
function-pointer-type
))
(
inst
move
cfp-tn
csp-tn
)
RETURN-NIL
(
inst
move
res
null-tn
))
src/assembly/sparc64/array.lisp
deleted
100644 → 0
View file @
0f4c649a
;;; -*- Package: SPARC -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(
ext:file-comment
"$Header: src/assembly/sparc/array.lisp $"
)
;;;
;;; **********************************************************************
;;;
;;; $Header: src/assembly/sparc/array.lisp $
;;;
;;; This file contains the support routines for arrays and vectors.
;;;
;;; Written by William Lott.
;;;
(
in-package
"SPARC"
)
(
define-assembly-routine
(
allocate-vector
(
:policy
:fast-safe
)
(
:translate
allocate-vector
)
(
:arg-types
positive-fixnum
positive-fixnum
positive-fixnum
))
((
:arg
type
any-reg
a0-offset
)
(
:arg
length
any-reg
a1-offset
)
(
:arg
words
any-reg
a2-offset
)
(
:res
result
descriptor-reg
a0-offset
)
(
:temp
ndescr
non-descriptor-reg
nl0-offset
)
(
:temp
gc-temp
non-descriptor-reg
nl1-offset
)
(
:temp
vector
descriptor-reg
a3-offset
))
(
pseudo-atomic
()
(
inst
add
ndescr
words
(
*
(
1+
vm:vector-data-offset
)
vm:word-bytes
))
(
inst
andn
ndescr
vm:lowtag-mask
)
(
allocation
vector
ndescr
other-pointer-type
:temp-tn
gc-temp
)
#+
gencgc
(
progn
;; ndescr points to one word past the end of the allocated
;; space. Fill the last word with a zero.
(
inst
add
ndescr
vector
)
(
storew
zero-tn
ndescr
-1
vm:other-pointer-type
))
(
inst
srl
ndescr
type
vm:word-shift
)
(
storew
ndescr
vector
0
vm:other-pointer-type
)
(
storew
length
vector
vm:vector-length-slot
vm:other-pointer-type
))
;; This makes sure the zero byte at the end of a string is paged in so
;; the kernel doesn't bitch if we pass it the string.
;;
;; This used to write to the word after the last allocated word. I
;; (RLT) made it write to the last allocated word, which is where
;; the zero-byte of the string is. Look at the deftransform for
;; make-array in array-tran.lisp. For strings we always allocate
;; enough space to hold the zero-byte.
#-
gencgc
(
storew
zero-tn
alloc-tn
-1
)
(
move
result
vector
))
;;;; Hash primitives
#+
assembler
(
defparameter
sxhash-simple-substring-entry
(
gen-label
))
(
define-assembly-routine
(
sxhash-simple-string
(
:translate
%sxhash-simple-string
)
(
:policy
:fast-safe
)
(
:result-types
positive-fixnum
))
((
:arg
string
descriptor-reg
a0-offset
)
(
:res
result
any-reg
a0-offset
)
(
:temp
length
any-reg
a1-offset
)
(
:temp
accum
non-descriptor-reg
nl0-offset
)
(
:temp
data
non-descriptor-reg
nl1-offset
)
(
:temp
temp
non-descriptor-reg
nl2-offset
)
(
:temp
offset
non-descriptor-reg
nl3-offset
))
(
declare
(
ignore
result
accum
data
temp
offset
))
(
inst
b
sxhash-simple-substring-entry
)
(
loadw
length
string
vm:vector-length-slot
vm:other-pointer-type
))
;; Implement the one-at-a-time algorithm designed by Bob Jenkins
;; (see <http://burtleburtle.net/bob/hash/doobs.html> for some
;; more information).
;;
;; For completeness, here is the hash function, in C, from that web
;; page. ub4 is an unsigned 32-bit integer.
#||
ub4 one_at_a_time(char *key, ub4 len)
{
ub4 hash, i;
for (hash=0, i=0; i<len; ++i)
{
hash += key[i];
hash += (hash << 10);
hash ^= (hash >> 6);
}
hash += (hash << 3);
hash ^= (hash >> 11);
hash += (hash << 15);
return (hash & mask);
}
||#
(
define-assembly-routine
(
sxhash-simple-substring
(
:translate
%sxhash-simple-substring
)
(
:policy
:fast-safe
)
(
:arg-types
*
positive-fixnum
)
(
:result-types
positive-fixnum
))
((
:arg
string
descriptor-reg
a0-offset
)
(
:arg
length
any-reg
a1-offset
)
(
:res
result
any-reg
a0-offset
)
(
:temp
accum
non-descriptor-reg
nl0-offset
)
(
:temp
data
non-descriptor-reg
nl1-offset
)
(
:temp
temp
non-descriptor-reg
nl2-offset
)
(
:temp
offset
non-descriptor-reg
nl3-offset
))
(
emit-label
sxhash-simple-substring-entry
)
#+
unicode
(
inst
sll
length
1
)
; Number of bytes = twice the length
(
inst
li
offset
(
-
(
*
vector-data-offset
word-bytes
)
other-pointer-type
))
(
inst
b
test
)
(
move
accum
zero-tn
)
LOOP
;; hash += key[i]
(
inst
add
accum
data
)
;; hash += (hash << 10)
(
inst
slln
temp
accum
10
)
(
inst
add
accum
temp
)
;; hash ^= (hash >> 6)
(
inst
srln
temp
accum
6
)
(
inst
xor
accum
temp
)
(
inst
add
offset
1
)
TEST
(
inst
subcc
length
(
fixnumize
1
))
(
inst
b
:ge
loop
)
(
inst
ldub
data
string
offset
)
;; hash += (hash << 3)
(
inst
slln
temp
accum
3
)
(
inst
add
accum
temp
)
;; hash ^= (hash >> 11)
(
inst
srln
temp
accum
11
)
(
inst
xor
accum
temp
)
;; hash += (hash << 15)
(
inst
slln
temp
accum
15
)
(
inst
add
accum
temp
)
;;(inst li temp most-positive-fixnum)
;;(inst and accum temp)
;; Make it a fixnum result
;; Make the result a positive fixnum. Shifting it left, then right
;; does what we want, and extracts the bits we need.
(
inst
slln
accum
(
1+
vm:fixnum-tag-bits
))
(
inst
srln
result
accum
1
))
src/assembly/sparc64/assem-rtns.lisp
deleted
100644 → 0
View file @
0f4c649a
;;; -*- Package: SPARC -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(
ext:file-comment
"$Header: src/assembly/sparc/assem-rtns.lisp $"
)
;;;
;;; **********************************************************************
;;;
;;; $Header: src/assembly/sparc/assem-rtns.lisp $
;;;
;;;
(
in-package
"SPARC"
)
;;;; Return-multiple with other than one value
#+
assembler
;; we don't want a vop for this one.
(
define-assembly-routine
(
return-multiple
(
:return-style
:none
))
;; These four are really arguments.
((
:temp
nvals
any-reg
nargs-offset
)
(
:temp
vals
any-reg
nl0-offset
)
(
:temp
ocfp
any-reg
nl1-offset
)
(
:temp
lra
descriptor-reg
lra-offset
)
;; These are just needed to facilitate the transfer
(
:temp
count
any-reg
nl2-offset
)
(
:temp
src
any-reg
nl3-offset
)
(
:temp
dst
any-reg
nl4-offset
)
(
:temp
temp
descriptor-reg
cname-offset
)
;; These are needed so we can get at the register args.
(
:temp
a0
descriptor-reg
a0-offset
)
(
:temp
a1
descriptor-reg
a1-offset
)
(
:temp
a2
descriptor-reg
a2-offset
)
(
:temp
a3
descriptor-reg
a3-offset
)
(
:temp
a4
descriptor-reg
a4-offset
)
(
:temp
a5
descriptor-reg
a5-offset
))
;; Note, because of the way the return-multiple vop is written, we can
;; assume that we are never called with nvals == 1 and that a0 has already
;; been loaded.
(
inst
cmp
nvals
)
(
inst
b
:le
default-a0-and-on
)
(
inst
cmp
nvals
(
fixnumize
2
))
(
inst
b
:le
default-a2-and-on
)
(
inst
ld
a1
vals
(
*
1
vm:word-bytes
))