Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
  • 7 commits
  • 49 files changed
  • 0 commit comments
  • 2 contributors
Commits on May 14, 2003
@csrhodes csrhodes alpha.0.28.alpha64.1:
	WILL NOT WORK!  WILL EAT YOUR LUNCH!

	This branch (alpha64_branch) is to attempt to make sbcl completely
	64-bit on the alpha.

	This commit allows the system to compile as far as second genesis, for
	the alpha.  It will almost certainly not work anywhere else.
56d75c4
@telent telent 0.8alpha.0.28.alpha64.2
	STILL NOT WORK!  SIX IMPOSSIBLE ASSERTIONS BEFORE LUNCH!

	Some fairly random 64 bit cleanups in genesis/runtime, to get
	an SBCL alpha that goes all the way through second genesis and
	a runtime that attempts to laod the core thus created.  Note
	that the core file thus produced can best be described as
	"broken"
a43cbf3
Commits on May 15, 2003
@csrhodes csrhodes 0.8alpha.0.28.alpha64.3:
	STILL WON'T WORK! ALMOST AS HUNGRY AS BEFORE!

	"fix" the double float digits problem, letting sbcl get to the
	end of host-2
81e03d7
Commits on May 17, 2003
@telent telent 0.8alpha.0.28.alpha64.4
	STILL BROKEN.  THANKS FOR ASKING.

	More 64 bit fixes:

	Semi-mechanical {ld,st}l -> {ld,st}q substitution throughout
	alpha backend

	Mostly mechanical: replace alpha conditionals all through objdef
	with alpha32

	emit-header-data (xep-allocate-frame): get the padding right
f842bf2
Commits on May 18, 2003
@telent telent 0.8alpha.0.28.alpha64.5
	AND THEN YOU'RE IN THE MAN FROM MARS. YOU GO OUT AT NIGHT, EATING CARS

	More random numbers:
	... changed lots of 3s to 7s in assembler/ (nb this code is
	    still wrong, which is why I haven't used a symbolic constant)

	... replace >>2 and <<2 in runtime with fixnum_value and make_fixnum

	... fix lisp-return in call.lisp to return to the right
	    address.  lispobj is 8 but instructions are still 4 bytes
	    long
c15f71d
Commits on May 22, 2003
@csrhodes csrhodes 0.8alpha.0.28.alpha64.6:
	MARGINALLY LESS BROKEN!  STILL VORACIOUS!

	(Mostly) fix fixnum arithmetic
	... frobbage in assembly/alpha/arith.lisp and compiler/alpha/arith.lisp
	... bignum stuff definitely broken (but with 61-bit fixnums,
		who cares? :-)
	... also fix things like CODE-CHAR/CHAR-CODE, since I'm grepping
		for "2".
	... frobbage in compiler/alpha/move.lisp to ensure that the system
		knows how to move fixnums to non-descriptors and back

	(Mostly) fix array references
	... now that N-WORD-BYTES is 64, (UNSIGNED-BYTE 32) arrays need to
		be referenced by a partial reffer, not a full reffer
	... write said partial reffer (compiler/alpha/macros.lisp) and use
		it (compiler/alpha/array.lisp)
	... also, a SIMPLE-VECTOR will take 64 bits per entry, so tell the
		compiler so (compiler/array-tran.lisp)

	(Partially) fix ldb
	... doesn't crash and burn horribly, and even prints some things
		out right.
a73ea93
@csrhodes csrhodes 0.8alpha.0.28.alpha64.7:
	STILL NON-FUNCTIONAL.  ESURIENT AS A SHARK.

	for now, since hash tables are still implemented with
	(UNSIGNED-BYTE 32) vectors
	... ensure that SXHASH returns an (UNSIGNED-BYTE 29)
	... and GLOBALDB-SXHASHOID, too

	(at this point, the system gets about one quarter of the
	way through reversed-toplevel-forms-and-fixups before dying
	with a segmentation fault)
32622b7
Showing with 420 additions and 342 deletions.
  1. +1 −1  build-order.lisp-expr
  2. +2 −1  package-data-list.lisp-expr
  3. +29 −28 src/assembly/alpha/arith.lisp
  4. +6 −0 src/code/array.lisp
  5. +2 −2 src/code/bit-bash.lisp
  6. +1 −1  src/code/numbers.lisp
  7. +5 −5 src/code/package.lisp
  8. +6 −0 src/code/target-hash-table.lisp
  9. +1 −1  src/code/target-sxhash.lisp
  10. +2 −1  src/compiler/alpha/alloc.lisp
  11. +13 −11 src/compiler/alpha/arith.lisp
  12. +19 −11 src/compiler/alpha/array.lisp
  13. +23 −23 src/compiler/alpha/call.lisp
  14. +2 −2 src/compiler/alpha/char.lisp
  15. +4 −4 src/compiler/alpha/debug.lisp
  16. +8 −8 src/compiler/alpha/float.lisp
  17. +5 −2 src/compiler/alpha/insts.lisp
  18. +80 −20 src/compiler/alpha/macros.lisp
  19. +12 −10 src/compiler/alpha/move.lisp
  20. +2 −2 src/compiler/alpha/parms.lisp
  21. +1 −1  src/compiler/alpha/static-fn.lisp
  22. +16 −11 src/compiler/alpha/system.lisp
  23. +4 −4 src/compiler/alpha/type-vops.lisp
  24. +1 −1  src/compiler/alpha/values.lisp
  25. +7 −6 src/compiler/alpha/vm.lisp
  26. +1 −1  src/compiler/array-tran.lisp
  27. +1 −1  src/compiler/early-assem.lisp
  28. +15 −10 src/compiler/generic/early-objdef.lisp
  29. +5 −3 src/compiler/generic/early-vm.lisp
  30. +22 −22 src/compiler/generic/genesis.lisp
  31. +1 −2  src/compiler/generic/late-type-vops.lisp
  32. +20 −20 src/compiler/generic/objdef.lisp
  33. +22 −11 src/compiler/generic/primtype.lisp
  34. +4 −3 src/compiler/generic/utils.lisp
  35. +4 −4 src/compiler/generic/vm-fndb.lisp
  36. +1 −1  src/compiler/generic/vm-type.lisp
  37. +3 −2 src/compiler/globaldb.lisp
  38. +36 −36 src/runtime/alpha-assem.S
  39. +1 −13 src/runtime/backtrace.c
  40. +1 −1  src/runtime/cheneygc.c
  41. +0 −8 src/runtime/core.h
  42. +3 −6 src/runtime/coreparse.c
  43. +1 −1  src/runtime/gc-common.c
  44. +1 −1  src/runtime/monitor.c
  45. +4 −3 src/runtime/parse.c
  46. +11 −26 src/runtime/print.c
  47. +6 −6 src/runtime/runtime.h
  48. +4 −4 src/runtime/thread.h
  49. +1 −1  version.lisp-expr
View
2  build-order.lisp-expr
@@ -91,9 +91,9 @@
;; for various constants e.g. SB!XC:MOST-POSITIVE-FIXNUM and
;; SB!VM:N-LOWTAG-BITS, needed by "early-objdef" and others
+ ("src/compiler/target/parms")
("src/compiler/generic/early-vm")
("src/compiler/generic/early-objdef")
- ("src/compiler/target/parms")
("src/code/early-array") ; needs "early-vm" numbers
("src/code/early-extensions") ; on host for COLLECT, SYMBOLICATE, etc.
View
3  package-data-list.lisp-expr
@@ -1956,7 +1956,8 @@ structure representations"
"OCFP-SAVE-OFFSET"
"ODD-FIXNUM-LOWTAG"
"OFFSET-STATIC-SYMBOL" "OTHER-IMMEDIATE-0-LOWTAG"
- "OTHER-IMMEDIATE-1-LOWTAG" "OTHER-POINTER-LOWTAG"
+ "OTHER-IMMEDIATE-1-LOWTAG" "OTHER-IMMEDIATE-2-LOWTAG"
+ "OTHER-IMMEDIATE-3-LOWTAG" "OTHER-POINTER-LOWTAG"
"PAD-DATA-BLOCK" "PENDING-INTERRUPT-TRAP"
"PRIMITIVE-OBJECT" "PRIMITIVE-OBJECT-WIDETAG"
"PRIMITIVE-OBJECT-LOWTAG" "PRIMITIVE-OBJECT-NAME"
View
57 src/assembly/alpha/arith.lisp
@@ -29,17 +29,18 @@
(:temp lra descriptor-reg lra-offset)
(:temp nargs any-reg nargs-offset)
(:temp ocfp any-reg ocfp-offset))
- (inst and x 3 temp)
+ (inst and x 7 temp)
(inst bne temp DO-STATIC-FUN)
- (inst and y 3 temp)
+ (inst and y 7 temp)
(inst bne temp DO-STATIC-FUN)
(inst addq x y res)
; Check whether we need a bignum.
- (inst sra res 31 temp)
+ (inst sra res 60 temp)
(inst beq temp DONE)
(inst not temp temp)
(inst beq temp DONE)
+ ;; FIXME: broken below here
(inst sra res 2 temp3)
; from move-from-signed
@@ -61,7 +62,7 @@
(lisp-return lra lip :offset 2)
DO-STATIC-FUN
- (inst ldl lip (static-fun-offset 'two-arg-+) null-tn)
+ (inst ldq lip (static-fun-offset 'two-arg-+) null-tn)
(inst li (fixnumize 2) nargs)
(inst move cfp-tn ocfp)
(inst move csp-tn cfp-tn)
@@ -86,17 +87,18 @@
(:temp lra descriptor-reg lra-offset)
(:temp nargs any-reg nargs-offset)
(:temp ocfp any-reg ocfp-offset))
- (inst and x 3 temp)
+ (inst and x 7 temp)
(inst bne temp DO-STATIC-FUN)
- (inst and y 3 temp)
+ (inst and y 7 temp)
(inst bne temp DO-STATIC-FUN)
(inst subq x y res)
; Check whether we need a bignum.
- (inst sra res 31 temp)
+ (inst sra res 60 temp)
(inst beq temp DONE)
(inst not temp temp)
(inst beq temp DONE)
+ ;; FIXME: broken below here
(inst sra res 2 temp3)
; from move-from-signed
@@ -118,7 +120,7 @@
(lisp-return lra lip :offset 2)
DO-STATIC-FUN
- (inst ldl lip (static-fun-offset 'two-arg--) null-tn)
+ (inst ldq lip (static-fun-offset 'two-arg--) null-tn)
(inst li (fixnumize 2) nargs)
(inst move cfp-tn ocfp)
(inst move csp-tn cfp-tn)
@@ -145,23 +147,21 @@
(:temp nargs any-reg nargs-offset)
(:temp ocfp any-reg ocfp-offset))
;; If either arg is not a fixnum, call the static function.
- (inst and x 3 temp)
+ (inst and x 7 temp)
(inst bne temp DO-STATIC-FUN)
- (inst and y 3 temp)
+ (inst and y 7 temp)
(inst bne temp DO-STATIC-FUN)
;; Remove the tag from one arg so that the result will have the
;; correct fixnum tag.
- (inst sra x 2 temp)
- (inst mulq temp y lo)
- (inst sra lo 32 hi)
- (inst sll lo 32 res)
- (inst sra res 32 res)
- ;; 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 res 31 temp)
- (inst xor hi temp temp)
+ (inst sra x 3 temp)
+ (inst mulq temp y res)
+ ;; FIXME: assumes unsigned multiply
+ (inst umulh temp y temp)
(inst beq temp DONE)
+
+ ;; FIXME: utterly, hopelessly broken.
+ ;;
;; Shift the double word hi:res down two bits into hi:low to get rid
;; of the fixnum tag.
(inst sra lo 2 lo)
@@ -241,6 +241,7 @@
(emit-label label))
(inst move zero-tn rem)
(inst move zero-tn quo)
+ ;; FIXME: hopelessly broken below here
(inst sll dividend 32 dividend)
(dotimes (i 32)
@@ -286,13 +287,13 @@
(:temp lip interior-reg lip-offset)
(:temp nargs any-reg nargs-offset)
(:temp ocfp any-reg ocfp-offset))
- (inst and x 3 temp)
+ (inst and x 7 temp)
(inst bne temp DO-STATIC-FN)
- (inst and y 3 temp)
+ (inst and y 7 temp)
(inst beq temp DO-COMPARE)
DO-STATIC-FN
- (inst ldl lip (static-fun-offset ',static-fn) null-tn)
+ (inst ldq lip (static-fun-offset ',static-fn) null-tn)
(inst li (fixnumize 2) nargs)
(inst move cfp-tn ocfp)
(inst move csp-tn cfp-tn)
@@ -327,9 +328,9 @@
(:temp ocfp any-reg ocfp-offset))
(inst cmpeq x y temp)
(inst bne temp RETURN-T)
- (inst and x 3 temp)
+ (inst and x 7 temp)
(inst beq temp RETURN-NIL)
- (inst and y 3 temp)
+ (inst and y 7 temp)
(inst bne temp DO-STATIC-FN)
RETURN-NIL
@@ -362,9 +363,9 @@
(:temp lra descriptor-reg lra-offset)
(:temp nargs any-reg nargs-offset)
(:temp ocfp any-reg ocfp-offset))
- (inst and x 3 temp)
+ (inst and x 7 temp)
(inst bne temp DO-STATIC-FN)
- (inst and y 3 temp)
+ (inst and y 7 temp)
(inst bne temp DO-STATIC-FN)
(inst cmpeq x y temp)
(inst bne temp RETURN-T)
@@ -398,9 +399,9 @@
(:temp lra descriptor-reg lra-offset)
(:temp nargs any-reg nargs-offset)
(:temp ocfp any-reg ocfp-offset))
- (inst and x 3 temp)
+ (inst and x 7 temp)
(inst bne temp DO-STATIC-FN)
- (inst and y 3 temp)
+ (inst and y 7 temp)
(inst bne temp DO-STATIC-FN)
(inst cmpeq x y temp)
(inst bne temp RETURN-NIL)
View
6 src/code/array.lisp
@@ -124,8 +124,11 @@
(values #.sb!vm:simple-array-signed-byte-8-widetag 8))
((signed-byte 16)
(values #.sb!vm:simple-array-signed-byte-16-widetag 16))
+ #!-alpha
((signed-byte 30)
(values #.sb!vm:simple-array-signed-byte-30-widetag 32))
+ ;; FIXME: add the larger specialized array types here,
+ ;; eventually
((signed-byte 32)
(values #.sb!vm:simple-array-signed-byte-32-widetag 32))
(single-float (values #.sb!vm:simple-array-single-float-widetag 32))
@@ -322,6 +325,7 @@
(unsigned-byte 32)
(signed-byte 8)
(signed-byte 16)
+ #!-alpha
(signed-byte 30)
(signed-byte 32)
single-float
@@ -566,6 +570,7 @@
(sb!vm:simple-array-unsigned-byte-32-widetag '(unsigned-byte 32))
(sb!vm:simple-array-signed-byte-8-widetag '(signed-byte 8))
(sb!vm:simple-array-signed-byte-16-widetag '(signed-byte 16))
+ #!-alpha
(sb!vm:simple-array-signed-byte-30-widetag '(signed-byte 30))
(sb!vm:simple-array-signed-byte-32-widetag '(signed-byte 32))
(sb!vm:simple-array-single-float-widetag 'single-float)
@@ -897,6 +902,7 @@
((simple-array (unsigned-byte 32) (*)) 0)
((simple-array (signed-byte 8) (*)) 0)
((simple-array (signed-byte 16) (*)) 0)
+ #!-alpha
((simple-array (signed-byte 30) (*)) 0)
((simple-array (signed-byte 32) (*)) 0)
((simple-array single-float (*)) (coerce 0 'single-float))
View
4 src/code/bit-bash.lisp
@@ -14,10 +14,10 @@
;;;; constants and types
;;; the number of bits to process at a time
-(defconstant unit-bits n-word-bits)
+(defconstant unit-bits 32) ; FIXME
;;; the maximum number of bits that can be dealt with in a single call
-(defconstant max-bits (ash most-positive-fixnum -2))
+(defconstant max-bits (ash (1- (ash 1 29)) -2)) ; FIXME
(deftype unit ()
`(unsigned-byte ,unit-bits))
View
2  src/code/numbers.lisp
@@ -1294,7 +1294,7 @@
(declare (type (signed-byte 31) res)
(optimize (inhibit-warnings 3)))
(return res))))))
- (declare (type (mod 30) k)
+ (declare (type (mod 30) k) ;FIXME 64bit
(type (signed-byte 31) u v)))))
((bignum bignum)
(bignum-gcd u v))
View
10 src/code/package.lisp
@@ -30,12 +30,12 @@
;;; the entry is unused. If it is one, then it is deleted.
;;; Double-hashing is used for collision resolution.
-(sb!xc:deftype hash-vector () '(simple-array (unsigned-byte 8) (*)))
+(def!type hash-vector () '(simple-array (unsigned-byte 8) (*)))
-(sb!xc:defstruct (package-hashtable
- (:constructor %make-package-hashtable
- (table hash size &aux (free size)))
- (:copier nil))
+(def!struct (package-hashtable
+ (:constructor %make-package-hashtable
+ (table hash size &aux (free size)))
+ (:copier nil))
;; The g-vector of symbols.
(table (missing-arg) :type simple-vector)
;; The i-vector of pname hash values.
View
6 src/code/target-hash-table.lisp
@@ -414,9 +414,15 @@
((not (zerop (hash-table-needing-rehash hash-table)))
(flush-needing-rehash hash-table)))
;; Search for key in the hash table.
+; (/show0 "in GETHASH, key=..")
+; (/hexstr key)
+; (/show0 "hash-table=..")
+; (/hexstr hash-table)
(multiple-value-bind (hashing eq-based)
(funcall (hash-table-hash-fun hash-table) key)
(declare (type hash hashing))
+; (/show0 "hashing=..")
+; (/hexstr hashing)
(let* ((index-vector (hash-table-index-vector hash-table))
(length (length index-vector))
(index (rem hashing length))
View
2  src/code/target-sxhash.lisp
@@ -65,7 +65,7 @@
(let* ((xy (+ (* x 3) y)))
(declare (type (unsigned-byte 32) xy))
(the (and fixnum unsigned-byte)
- (logand most-positive-fixnum
+ (logand 536870911
(logxor 441516657
xy
(the fixnum (ash xy -5)))))))
View
3  src/compiler/alpha/alloc.lisp
@@ -169,7 +169,8 @@
(:temporary (:scs (non-descriptor-reg)) bytes)
(:generator 6
(inst lda bytes (* (1+ words) n-word-bytes) extra)
- (inst sll bytes (- n-widetag-bits 2) header)
+ (inst sll bytes (- n-widetag-bits 3) header)
+ ;; ??
(inst lda header (+ (ash -2 n-widetag-bits) type) header)
(inst srl bytes n-lowtag-bits bytes)
(inst sll bytes n-lowtag-bits bytes)
View
24 src/compiler/alpha/arith.lisp
@@ -147,12 +147,12 @@
(:generator ,untagged-cost
(inst ,op x y r)))))))
-(define-binop + 1 5 addq (unsigned-byte 6) (unsigned-byte 8))
-(define-binop - 1 5 subq (unsigned-byte 6) (unsigned-byte 8))
-(define-binop logior 1 3 bis (unsigned-byte 6) (unsigned-byte 8))
-(define-binop lognor 1 3 ornot (unsigned-byte 6) (unsigned-byte 8))
-(define-binop logand 1 3 and (unsigned-byte 6) (unsigned-byte 8))
-(define-binop logxor 1 3 xor (unsigned-byte 6) (unsigned-byte 8))
+(define-binop + 1 5 addq (unsigned-byte 5) (unsigned-byte 8))
+(define-binop - 1 5 subq (unsigned-byte 5) (unsigned-byte 8))
+(define-binop logior 1 3 bis (unsigned-byte 5) (unsigned-byte 8))
+(define-binop lognor 1 3 ornot (unsigned-byte 5) (unsigned-byte 8))
+(define-binop logand 1 3 and (unsigned-byte 5) (unsigned-byte 8))
+(define-binop logxor 1 3 xor (unsigned-byte 5) (unsigned-byte 8))
;;;; shifting
@@ -271,7 +271,7 @@
(:temporary (:scs (non-descriptor-reg)) temp)
(:translate *)
(:generator 4
- (inst sra y 2 temp)
+ (inst sra y 3 temp)
(inst mulq x temp r)))
(define-vop (fast-*/signed=>signed fast-signed-binop)
@@ -302,7 +302,8 @@
(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
(:args (x :scs (any-reg)))
- (:arg-types tagged-num (:constant (unsigned-byte-with-a-bite-out 6 4)))
+ ;; FIXME: Think harder about how big the bite should be.
+ (:arg-types tagged-num (:constant (unsigned-byte-with-a-bite-out 5 4)))
(:info target not-p y))
(define-vop (fast-conditional/signed fast-conditional)
@@ -426,7 +427,7 @@
(define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
(:args (x :scs (any-reg)))
- (:arg-types tagged-num (:constant (signed-byte 6)))
+ (:arg-types tagged-num (:constant (signed-byte 5)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:info target not-p y)
(:translate eql)
@@ -442,7 +443,7 @@
;;;
(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
(:args (x :scs (any-reg descriptor-reg)))
- (:arg-types * (:constant (signed-byte 6)))
+ (:arg-types * (:constant (signed-byte 5)))
(:variant-cost 6))
@@ -682,7 +683,8 @@
(:results (digit :scs (unsigned-reg)))
(:result-types unsigned-num)
(:generator 1
- (inst sra fixnum 2 digit)))
+ ;; probably (bignum stuff is broken anyway)
+ (inst sra fixnum 3 digit)))
(define-vop (bignum-floor)
(:translate sb!bignum::%floor)
View
30 src/compiler/alpha/array.lisp
@@ -31,7 +31,7 @@
(inst addq rank (fixnumize (1- array-dimensions-offset)) header)
(inst sll header n-widetag-bits header)
(inst bis header type header)
- (inst srl header 2 header)
+ (inst srl header 3 header)
(pseudo-atomic ()
(inst bis alloc-tn other-pointer-lowtag result)
(storew header result 0 other-pointer-lowtag)
@@ -67,7 +67,7 @@
(loadw temp x 0 other-pointer-lowtag)
(inst sra temp n-widetag-bits temp)
(inst subq temp (1- array-dimensions-offset) temp)
- (inst sll temp 2 res)))
+ (inst sll temp 3 res)))
@@ -139,7 +139,7 @@
temp result)
(:generator 20
(inst srl index ,bit-shift temp)
- (inst sll temp 2 temp)
+ (inst sll temp 3 temp)
(inst addq object temp lip)
(inst ldl result
(- (* vector-data-offset n-word-bytes)
@@ -151,7 +151,7 @@
,(1- (integer-length bits)) temp)))
(inst srl result temp result)
(inst and result ,(1- (ash 1 bits)) result)
- (inst sll result 2 value)))
+ (inst sll result 3 value)))
(define-vop (,(symbolicate 'data-vector-ref-c/ type))
(:translate data-vector-ref)
(:policy :fast-safe)
@@ -195,9 +195,9 @@
:from (:argument 1)) shift)
(:generator 25
(inst srl index ,bit-shift temp)
- (inst sll temp 2 temp)
+ (inst sll temp 3 temp)
(inst addq object temp lip)
- (inst ldl old
+ (inst ldq old
(- (* vector-data-offset n-word-bytes)
other-pointer-lowtag)
lip)
@@ -318,21 +318,26 @@
:byte nil unsigned-reg signed-reg)
(def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
+ ;; change this to "WORD", probably
:short nil unsigned-reg signed-reg)
- (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
+ (def-partial-data-vector-frobs simple-array-unsigned-byte-32 positive-fixnum
+ :longword nil unsigned-reg signed-reg)
+
+ (def-full-data-vector-frobs simple-array-unsigned-byte-64 unsigned-num
unsigned-reg)
-
+
(def-partial-data-vector-frobs simple-array-signed-byte-8 tagged-num
:byte t signed-reg)
(def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num
:short t signed-reg)
- (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg)
+ (def-partial-data-vector-frobs simple-array-signed-byte-30 tagged-num
+ :longword t signed-reg)
- (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num
- signed-reg)
+ (def-partial-data-vector-frobs simple-array-signed-byte-32 signed-num
+ :longword t signed-reg)
;; Integer vectors whos elements are smaller than a byte. I.e. bit,
;; 2-bit, and 4-bit vectors.
@@ -352,6 +357,9 @@
(:results (value :scs (single-reg)))
(:result-types single-float)
(:temporary (:scs (interior-reg)) lip)
+ ;; Hmm. I think these arrays are wrong, too, because they assume
+ ;; that single-float is the size of a lispobj, and that double-float
+ ;; is the size of two lispobjs.
(:generator 20
(inst addq object index lip)
(inst lds value
View
46 src/compiler/alpha/call.lisp
@@ -136,8 +136,8 @@
(emit-label start-lab)
;; Allocate function header.
(inst simple-fun-header-word)
- (dotimes (i (1- simple-fun-code-offset))
- (inst lword 0))
+ (dotimes (i (* n-word-bytes (1- simple-fun-code-offset)))
+ (inst byte 0))
;; The start of the actual code.
;; Compute CODE from the address of this entry point.
(let ((entry-point (gen-label)))
@@ -307,7 +307,7 @@ default-value-8
(defaults (cons default-lab tn))
(inst blt temp default-lab)
- (inst ldl move-temp (* i n-word-bytes) ocfp-tn)
+ (inst ldq move-temp (* i n-word-bytes) ocfp-tn)
(inst subq temp (fixnumize 1) temp)
(store-stack-tn tn move-temp)))
@@ -541,18 +541,18 @@ default-value-8
(:ignore val-locs vals)
(:vop-var vop)
(:generator 6
- (trace-table-entry trace-table-fun-epilogue)
- (maybe-load-stack-tn ocfp-temp ocfp)
- (maybe-load-stack-tn return-pc-temp return-pc)
- (move cfp-tn csp-tn)
- (let ((cur-nfp (current-nfp-tn vop)))
+ (trace-table-entry trace-table-fun-epilogue)
+ (maybe-load-stack-tn ocfp-temp ocfp)
+ (maybe-load-stack-tn return-pc-temp return-pc)
+ (move cfp-tn csp-tn)
+ (let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
(inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
nsp-tn)))
- (inst subq return-pc-temp (- other-pointer-lowtag n-word-bytes) lip)
- (move ocfp-temp cfp-tn)
- (inst ret zero-tn lip 1)
- (trace-table-entry trace-table-normal)))
+ (inst subq return-pc-temp (- other-pointer-lowtag n-word-bytes) lip)
+ (move ocfp-temp cfp-tn)
+ (inst ret zero-tn lip 1)
+ (trace-table-entry trace-table-normal)))
;;;; full call:
;;;;
@@ -710,7 +710,7 @@ default-value-8
`((inst subq csp-tn new-fp nargs-pass)
,@(let ((index -1))
(mapcar (lambda (name)
- `(inst ldl ,name
+ `(inst ldq ,name
,(ash (incf index)
word-shift)
new-fp))
@@ -722,7 +722,7 @@ default-value-8
(any-reg
(inst move ocfp ocfp-pass))
(control-stack
- (inst ldl ocfp-pass
+ (inst ldq ocfp-pass
(ash (tn-offset ocfp)
word-shift)
cfp-tn))))
@@ -731,7 +731,7 @@ default-value-8
(#!-gengc descriptor-reg #!+gengc any-reg
(inst move return-pc return-pc-pass))
(control-stack
- (inst ldl return-pc-pass
+ (inst ldq return-pc-pass
(ash (tn-offset return-pc)
word-shift)
cfp-tn))))
@@ -760,31 +760,31 @@ default-value-8
`((sc-case name
(descriptor-reg (move name name-pass))
(control-stack
- (inst ldl name-pass
+ (inst ldq name-pass
(ash (tn-offset name) word-shift) cfp-tn)
(do-next-filler))
(constant
- (inst ldl name-pass
+ (inst ldq name-pass
(- (ash (tn-offset name) word-shift)
other-pointer-lowtag) code-tn)
(do-next-filler)))
- (inst ldl entry-point
+ (inst ldq entry-point
(- (ash fdefn-raw-addr-slot word-shift)
other-pointer-lowtag) name-pass)
(do-next-filler))
`((sc-case arg-fun
(descriptor-reg (move arg-fun lexenv))
(control-stack
- (inst ldl lexenv
+ (inst ldq lexenv
(ash (tn-offset arg-fun) word-shift) cfp-tn)
(do-next-filler))
(constant
- (inst ldl lexenv
+ (inst ldq lexenv
(- (ash (tn-offset arg-fun) word-shift)
other-pointer-lowtag) code-tn)
(do-next-filler)))
#!-gengc
- (inst ldl function
+ (inst ldq function
(- (ash closure-fun-slot word-shift)
fun-pointer-lowtag) lexenv)
#!-gengc
@@ -794,7 +794,7 @@ default-value-8
(- (ash simple-fun-code-offset word-shift)
fun-pointer-lowtag) entry-point)
#!+gengc
- (inst ldl entry-point
+ (inst ldq entry-point
(- (ash closure-entry-point-slot word-shift)
fun-pointer-lowtag) lexenv)
#!+gengc
@@ -994,7 +994,7 @@ default-value-8
;; Check for the single case.
(inst li (fixnumize 1) a0)
(inst cmpeq nvals-arg a0 temp)
- (inst ldl a0 0 vals-arg)
+ (inst ldq a0 0 vals-arg)
(inst beq temp not-single)
;; Return with one value.
View
4 src/compiler/alpha/char.lisp
@@ -83,7 +83,7 @@
(:results (res :scs (any-reg)))
(:result-types positive-fixnum)
(:generator 1
- (inst sll ch 2 res)))
+ (inst sll ch 3 res)))
(define-vop (code-char)
(:translate code-char)
@@ -93,7 +93,7 @@
(:results (res :scs (base-char-reg)))
(:result-types base-char)
(:generator 1
- (inst srl code 2 res)))
+ (inst srl code 3 res)))
;;;; comparison of BASE-CHARs
View
8 src/compiler/alpha/debug.lisp
@@ -38,7 +38,7 @@
(:result-types *)
(:generator 5
(inst addq object offset sap)
- (inst ldl result 0 sap)))
+ (inst ldq result 0 sap)))
(define-vop (read-control-stack-c)
(:translate stack-ref)
@@ -49,7 +49,7 @@
(:results (result :scs (descriptor-reg)))
(:result-types *)
(:generator 4
- (inst ldl result (* offset n-word-bytes) object)))
+ (inst ldq result (* offset n-word-bytes) object)))
(define-vop (write-control-stack)
(:translate %set-stack-ref)
@@ -63,7 +63,7 @@
(:temporary (:scs (sap-reg) :from (:argument 1)) sap)
(:generator 2
(inst addq object offset sap)
- (inst stl value 0 sap)
+ (inst stq value 0 sap)
(move value result)))
(define-vop (write-control-stack-c)
@@ -76,7 +76,7 @@
(:results (result :scs (descriptor-reg)))
(:result-types *)
(:generator 1
- (inst stl value (* offset n-word-bytes) sap)
+ (inst stq value (* offset n-word-bytes) sap)
(move value result)))
View
16 src/compiler/alpha/float.lisp
@@ -498,7 +498,7 @@
(let ((stack-tn
(sc-case x
(signed-reg
- (inst stl x
+ (inst stq x
(* (tn-offset temp)
n-word-bytes)
(current-nfp-tn vop))
@@ -613,7 +613,7 @@
(current-nfp-tn vop)))
(single-stack
(unless (location= bits res)
- (inst ldl temp
+ (inst ldq temp
(* (tn-offset bits) n-word-bytes)
(current-nfp-tn vop))
(inst stl temp
@@ -666,11 +666,11 @@
(inst sts float
(* (tn-offset stack-temp) n-word-bytes)
(current-nfp-tn vop))
- (inst ldl bits
+ (inst ldq bits
(* (tn-offset stack-temp) n-word-bytes)
(current-nfp-tn vop)))
(single-stack
- (inst ldl bits
+ (inst ldq bits
(* (tn-offset float) n-word-bytes)
(current-nfp-tn vop)))
(descriptor-reg
@@ -699,11 +699,11 @@
(inst stt float
(* (tn-offset stack-temp) n-word-bytes)
(current-nfp-tn vop))
- (inst ldl hi-bits
+ (inst ldq hi-bits
(* (1+ (tn-offset stack-temp)) n-word-bytes)
(current-nfp-tn vop)))
(double-stack
- (inst ldl hi-bits
+ (inst ldq hi-bits
(* (1+ (tn-offset float)) n-word-bytes)
(current-nfp-tn vop)))
(descriptor-reg
@@ -726,11 +726,11 @@
(inst stt float
(* (tn-offset stack-temp) n-word-bytes)
(current-nfp-tn vop))
- (inst ldl lo-bits
+ (inst ldq lo-bits
(* (tn-offset stack-temp) n-word-bytes)
(current-nfp-tn vop)))
(double-stack
- (inst ldl lo-bits
+ (inst ldq lo-bits
(* (tn-offset float) n-word-bytes)
(current-nfp-tn vop)))
(descriptor-reg
View
7 src/compiler/alpha/insts.lisp
@@ -539,10 +539,13 @@
(emit-byte segment byte)))
(defun emit-header-data (segment type)
+ ;; this version hardcoded for 8 byte words: change emit-qword to
+ ;; something else for other lengths
+ (aver (= n-word-bytes 8))
(emit-back-patch
- segment 4
+ segment n-word-bytes
(lambda (segment posn)
- (emit-lword segment
+ (emit-qword segment
(logior type
(ash (+ posn (component-header-length))
(- n-widetag-bits word-shift)))))))
View
100 src/compiler/alpha/macros.lisp
@@ -37,7 +37,8 @@
`(unless (location= ,n-src ,n-dst)
(inst move ,n-src ,n-dst))))
-(defmacro loadw (result base &optional (offset 0) (lowtag 0))
+;;; this was called loadw, when we had 32 bit words
+(defmacro loadl (result base &optional (offset 0) (lowtag 0))
(once-only ((result result) (base base))
`(inst ldl ,result (- (ash ,offset word-shift) ,lowtag) ,base)))
@@ -45,27 +46,31 @@
(once-only ((result result) (base base))
`(inst ldq ,result (- (ash ,offset word-shift) ,lowtag) ,base)))
-(defmacro storew (value base &optional (offset 0) (lowtag 0))
+(defmacro loadw (&rest stuff) `(loadq ,@stuff))
+
+;;; was storew when we had 32 bit words
+(defmacro storel (value base &optional (offset 0) (lowtag 0))
(once-only ((value value) (base base) (offset offset) (lowtag lowtag))
`(inst stl ,value (- (ash ,offset word-shift) ,lowtag) ,base)))
(defmacro storeq (value base &optional (offset 0) (lowtag 0))
(once-only ((value value) (base base) (offset offset) (lowtag lowtag))
`(inst stq ,value (- (ash ,offset word-shift) ,lowtag) ,base)))
+(defmacro storew (&rest stuff) `(storeq ,@stuff))
(defmacro load-symbol (reg symbol)
(once-only ((reg reg) (symbol symbol))
`(inst lda ,reg (static-symbol-offset ,symbol) null-tn)))
(defmacro load-symbol-value (reg symbol)
- `(inst ldl ,reg
+ `(inst ldq ,reg
(+ (static-symbol-offset ',symbol)
(ash symbol-value-slot word-shift)
(- other-pointer-lowtag))
null-tn))
(defmacro store-symbol-value (reg symbol)
- `(inst stl ,reg
+ `(inst stq ,reg
(+ (static-symbol-offset ',symbol)
(ash symbol-value-slot word-shift)
(- other-pointer-lowtag))
@@ -78,7 +83,7 @@
(n-source source)
(n-offset offset))
`(progn
- (inst ldl ,n-target ,n-offset ,n-source)
+ (inst ldq ,n-target ,n-offset ,n-source)
(inst and ,n-target #xff ,n-target))))
;;; macros to handle the fact that we cannot use the machine native
@@ -96,9 +101,9 @@
(defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
"Return to RETURN-PC. LIP is an interior-reg temporary."
`(progn
- (inst lda ,lip
- (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag)
- ,return-pc)
+ (inst lda ,lip
+ (- (+ n-word-bytes (* 4 ,offset)) other-pointer-lowtag)
+ ,return-pc)
,@(when frob-code
`((move ,return-pc code-tn)))
(inst ret zero-tn ,lip 1)))
@@ -259,9 +264,7 @@
(:result-types ,el-type)
(:generator 5
(inst addq object index lip)
- (inst ldl value (- (* ,offset n-word-bytes) ,lowtag) lip)
- ,@(when (equal scs '(unsigned-reg))
- '((inst mskll value 4 value)))))
+ (inst ldq value (- (* ,offset n-word-bytes) ,lowtag) lip)))
(define-vop (,(symbolicate name "-C"))
,@(when translate
`((:translate ,translate)))
@@ -274,10 +277,8 @@
(:results (value :scs ,scs))
(:result-types ,el-type)
(:generator 4
- (inst ldl value (- (* (+ ,offset index) n-word-bytes) ,lowtag)
- object)
- ,@(when (equal scs '(unsigned-reg))
- '((inst mskll value 4 value)))))))
+ (inst ldq value (- (* (+ ,offset index) n-word-bytes) ,lowtag)
+ object)))))
(defmacro define-full-setter (name type offset lowtag scs el-type
&optional translate #!+gengc (remember t))
@@ -318,7 +319,7 @@
(defmacro define-partial-reffer (name type size signed offset lowtag scs
el-type &optional translate)
- (let ((scale (ecase size (:byte 1) (:short 2))))
+ (let ((scale (ecase size (:byte 1) (:short 2) (:longword 4))))
`(progn
(define-vop (,name)
,@(when translate
@@ -336,6 +337,10 @@
(inst addq object index lip)
,@(when (eq size :short)
'((inst addq index lip lip)))
+ ,@(when (eq size :longword)
+ '((inst addq index lip lip)
+ (inst addq index lip lip)
+ (inst addq index lip lip)))
,@(ecase size
(:byte
(if signed
@@ -364,7 +369,21 @@
`((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
lip)
(inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
- (inst extwl temp temp1 value)))))))
+ (inst extwl temp temp1 value))))
+ (:longword
+ (if signed
+ `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
+ lip)
+ (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag)
+ lip)
+ (inst extll temp temp1 temp)
+ (inst sll temp 32 temp)
+ (inst sra temp 32 value))
+ `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
+ lip)
+ (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag)
+ lip)
+ (inst extll temp temp1 value)))))))
(define-vop (,(symbolicate name "-C"))
,@(when translate
`((:translate ,translate)))
@@ -415,11 +434,29 @@
(inst lda temp1 (- (+ (* ,offset n-word-bytes)
(* index ,scale)) ,lowtag)
object)
- (inst extwl temp temp1 value))))))))))
+ (inst extwl temp temp1 value))))
+ (:longword
+ (if signed
+ `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
+ (* index ,scale)) ,lowtag)
+ object)
+ (inst lda temp1 (- (+ (* ,offset n-word-bytes)
+ (* index ,scale)) ,lowtag)
+ object)
+ (inst extll temp temp1 temp)
+ (inst sll temp 32 temp)
+ (inst sra temp 32 value))
+ `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
+ (* index ,scale)) ,lowtag)
+ object)
+ (inst lda temp1 (- (+ (* ,offset n-word-bytes)
+ (* index ,scale)) ,lowtag)
+ object)
+ (inst extll temp temp1 value))))))))))
(defmacro define-partial-setter (name type size offset lowtag scs el-type
&optional translate)
- (let ((scale (ecase size (:byte 1) (:short 2))))
+ (let ((scale (ecase size (:byte 1) (:short 2) (:longword 4))))
`(progn
(define-vop (,name)
,@(when translate
@@ -439,6 +476,10 @@
(inst addq object index lip)
,@(when (eq size :short)
'((inst addq lip index lip)))
+ ,@(when (eq size :longword)
+ '((inst addq lip index lip)
+ (inst addq lip index lip)
+ (inst addq lip index lip)))
,@(ecase size
(:byte
`((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip)
@@ -453,7 +494,14 @@
(inst mskwl temp1 temp temp1)
(inst inswl value temp temp2)
(inst bis temp1 temp2 temp)
- (inst stq_u temp (- (* ,offset n-word-bytes) ,lowtag) lip))))
+ (inst stq_u temp (- (* ,offset n-word-bytes) ,lowtag) lip)))
+ (:longword
+ `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip)
+ (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
+ (inst mskll temp1 temp temp1)
+ (inst insll value temp temp2)
+ (inst bis temp1 temp2 temp1)
+ (inst stq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip))))
(move value result)))
(define-vop (,(symbolicate name "-C"))
,@(when translate
@@ -497,5 +545,17 @@
(inst inswl value temp temp2)
(inst bis temp1 temp2 temp)
(inst stq_u temp (- (* ,offset n-word-bytes)
+ (* index ,scale) ,lowtag) object)))
+ (:longword
+ `((inst lda temp (- (* ,offset n-word-bytes)
+ (* index ,scale) ,lowtag)
+ object)
+ (inst ldq_u temp1 (- (* ,offset n-word-bytes)
+ (* index ,scale) ,lowtag)
+ object)
+ (inst mskll temp1 temp temp1)
+ (inst insll value temp temp2)
+ (inst bis temp1 temp2 temp)
+ (inst stq_u temp (- (* ,offset n-word-bytes)
(* index ,scale) ,lowtag) object))))
(move value result))))))
View
22 src/compiler/alpha/move.lisp
@@ -151,7 +151,7 @@
(:arg-types tagged-num)
(:note "fixnum untagging")
(:generator 1
- (inst sra x 2 y)))
+ (inst sra x (1- n-lowtag-bits) y)))
;;;
(define-move-vop move-to-word/fixnum :move
(any-reg descriptor-reg) (signed-reg unsigned-reg))
@@ -175,8 +175,8 @@
(:temporary (:sc non-descriptor-reg) header)
(:temporary (:scs (non-descriptor-reg)) temp)
(:generator 3
- (inst and x 3 temp)
- (inst sra x 2 y)
+ (inst and x (ash lowtag-mask -1) temp)
+ (inst sra x (1- n-lowtag-bits) y)
(inst beq temp done)
(loadw header x 0 other-pointer-lowtag)
@@ -186,6 +186,7 @@
(loadw header x (1+ bignum-digits-offset) other-pointer-lowtag)
(inst sll header 32 header)
+ ;; FIXME
(inst mskll y 4 y)
(inst bis header y y)
(inst br zero-tn done)
@@ -206,7 +207,7 @@
(:result-types tagged-num)
(:note "fixnum tagging")
(:generator 1
- (inst sll x 2 y)))
+ (inst sll x (1- n-lowtag-bits) y)))
;;;
(define-move-vop move-from-word/fixnum :move
(signed-reg unsigned-reg) (any-reg descriptor-reg))
@@ -221,12 +222,13 @@
(:note "signed word to integer coercion")
(:generator 18
(move arg x)
- (inst sra x 29 temp)
- (inst sll x 2 y)
+ ;; FIXME: bare constants
+ (inst sra x 60 temp)
+ (inst sll x 3 y)
(inst beq temp done)
(inst not temp temp)
(inst beq temp done)
-
+ ;; FIXME: bignum stuff
(inst li 2 header)
(inst sra x 31 temp)
(inst cmoveq temp 1 header)
@@ -258,10 +260,10 @@
(:note "unsigned word to integer coercion")
(:generator 20
(move arg x)
- (inst srl x 29 temp)
- (inst sll x 2 y)
+ (inst srl x 60 temp)
+ (inst sll x 3 y)
(inst beq temp done)
-
+ ;; FIXME: bignum stuff
(inst li 3 temp)
(inst cmovge x 2 temp)
(inst srl x 31 temp1)
View
4 src/compiler/alpha/parms.lisp
@@ -11,7 +11,7 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
-(def!constant n-word-bits 32
+(def!constant n-word-bits 64
#!+sb-doc
"Number of bits per word where a word holds one lisp descriptor.")
@@ -49,7 +49,7 @@
(+ (byte-size single-float-significand-byte) 1))
(def!constant double-float-digits
- (+ (byte-size double-float-significand-byte) n-word-bits 1))
+ (+ (byte-size double-float-significand-byte) 32 1))
;;; These values are originally from the DEC Assembly Language
;;; Programmers guide. Where possible we read/write the software
View
2  src/compiler/alpha/static-fn.lisp
@@ -77,7 +77,7 @@
(cur-nfp (current-nfp-tn vop)))
,@(moves (arg-names) (temp-names))
(inst li (fixnumize ,num-args) nargs)
- (inst ldl entry-point (static-fun-offset symbol) null-tn)
+ (inst ldq entry-point (static-fun-offset symbol) null-tn)
(when cur-nfp
(store-stack-tn nfp-save cur-nfp))
(inst move cfp-tn ocfp)
View
27 src/compiler/alpha/system.lisp
@@ -41,7 +41,7 @@
(inst blbs object done)
;; Pick off fixnums.
- (inst and object 3 result)
+ (inst and object (ash lowtag-mask -1) result)
(inst beq result done)
;; Must be an other immediate.
@@ -76,10 +76,10 @@
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
- (inst ldl temp (- fun-pointer-lowtag) function)
+ (inst ldq temp (- fun-pointer-lowtag) function)
(inst and temp #xff temp)
(inst bis type temp temp)
- (inst stl temp (- fun-pointer-lowtag) function)
+ (inst stq temp (- fun-pointer-lowtag) function)
(move type result)))
@@ -116,7 +116,7 @@
(inst and t1 widetag-mask t1)
(sc-case data
(any-reg
- (inst sll data (- n-widetag-bits 2) t2)
+ (inst sll data (- n-widetag-bits 3) t2)
(inst bis t1 t2 t1))
(immediate
(let ((c (ash (tn-value data) n-widetag-bits)))
@@ -129,15 +129,20 @@
(storew t1 x 0 other-pointer-lowtag)
(move x res)))
+;;; FIXME: Turn this VOP into MAKE-POSITIVE-FIXNUM
(define-vop (make-fixnum)
(:args (ptr :scs (any-reg descriptor-reg)))
(:results (res :scs (any-reg descriptor-reg)))
(:generator 1
- ;;
;; Some code (the hash table code) depends on this returning a
;; positive number so make sure it does.
- (inst sll ptr 35 res)
- (inst srl res 33 res)))
+ ;;
+ ;; A word of explanation: we make a net shift by 3 to clear the
+ ;; three lowest bits -- but we wish to return a positive fixnum,
+ ;; so shift by four and then back by one to ensure that the top
+ ;; bit is 0 too.
+ (inst sll ptr 4 res)
+ (inst srl res 1 res)))
(define-vop (make-other-immediate-type)
(:args (val :scs (any-reg descriptor-reg))
@@ -151,8 +156,8 @@
(inst sll val n-widetag-bits temp)
(inst bis temp (tn-value type) res))
(t
- (inst sra type 2 temp)
- (inst sll val (- n-widetag-bits 2) res)
+ (inst sra type 3 temp)
+ (inst sll val (- n-widetag-bits 3) res)
(inst bis res temp res)))))
@@ -241,6 +246,6 @@
(let ((offset
(- (* (+ index vector-data-offset) n-word-bytes)
other-pointer-lowtag)))
- (inst ldl count offset count-vector)
+ (inst ldq count offset count-vector)
(inst addq count 1 count)
- (inst stl count offset count-vector))))
+ (inst stq count offset count-vector))))
View
8 src/compiler/alpha/type-vops.lisp
@@ -13,7 +13,7 @@
(defun %test-fixnum (value target not-p &key temp)
(assemble ()
- (inst and value 3 temp)
+ (inst and value (ash lowtag-mask -1) temp)
(if not-p
(inst bne temp target)
(inst beq temp target))))
@@ -21,7 +21,7 @@
(defun %test-fixnum-and-headers (value target not-p headers &key temp)
(let ((drop-through (gen-label)))
(assemble ()
- (inst and value 3 temp)
+ (inst and value (ash lowtag-mask -1) temp)
(inst beq temp (if not-p drop-through target)))
(%test-headers value target not-p nil headers
:drop-through drop-through :temp temp)))
@@ -144,7 +144,7 @@
(values not-target target)
(values target not-target))
(assemble ()
- (inst and value 3 temp)
+ (inst and value (ash lowtag-mask -1) temp)
(inst beq temp yep)
(inst and value lowtag-mask temp)
(inst xor temp other-pointer-lowtag temp)
@@ -184,7 +184,7 @@
(values target not-target))
(assemble ()
;; Is it a fixnum?
- (inst and value 3 temp1)
+ (inst and value (ash lowtag-mask -1) temp1)
(inst move value temp)
(inst beq temp1 fixnum)
View
2  src/compiler/alpha/values.lisp
@@ -112,7 +112,7 @@
(inst move csp-tn dst)
(inst addq csp-tn count csp-tn)
LOOP
- (inst ldl temp 0 src)
+ (inst ldq temp 0 src)
(inst addq src 4 src)
(inst addq dst 4 dst)
(inst stl temp -4 dst)
View
13 src/compiler/alpha/vm.lisp
@@ -288,20 +288,21 @@
((integer 0 0)
(sc-number-or-lose 'zero))
(null
- (sc-number-or-lose 'null ))
- ((or fixnum system-area-pointer character)
- (sc-number-or-lose 'immediate ))
+ (sc-number-or-lose 'null))
+ ((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
+ system-area-pointer character)
+ (sc-number-or-lose 'immediate))
(symbol
(if (static-symbol-p value)
- (sc-number-or-lose 'immediate )
+ (sc-number-or-lose 'immediate)
nil))
(single-float
(if (eql value 0f0)
- (sc-number-or-lose 'fp-single-zero )
+ (sc-number-or-lose 'fp-single-zero)
nil))
(double-float
(if (eql value 0d0)
- (sc-number-or-lose 'fp-double-zero )
+ (sc-number-or-lose 'fp-double-zero)
nil))))
;;;; function call parameters
View
2  src/compiler/array-tran.lisp
@@ -264,7 +264,7 @@
#!+long-float ((complex long-float) #C(0.0L0 0.0L0)
#!+x86 192 #!+sparc 256
,sb!vm:simple-array-complex-long-float-widetag)
- (t 0 32 ,sb!vm:simple-vector-widetag))))
+ (t 0 64 ,sb!vm:simple-vector-widetag))))
(deftransform make-array ((dims &key initial-element element-type
adjustable fill-pointer)
View
2  src/compiler/early-assem.lisp
@@ -45,7 +45,7 @@
;;; the maximum alignment we can guarantee given the object format. If
;;; the loader only loads objects 8-byte aligned, we can't do any
;;; better then that ourselves.
-(def!constant max-alignment 3)
+(def!constant max-alignment sb!vm:n-lowtag-bits)
(deftype alignment ()
`(integer 0 ,max-alignment))
View
25 src/compiler/generic/early-objdef.lisp
@@ -24,14 +24,16 @@
;;; * EVEN-FIXNUM-LOWTAG and ODD-FIXNUM-LOWTAG must be 0 and 4: code
;;; which shifts left two places to convert raw integers to tagged
;;; fixnums is ubiquitous.
-;;; * LIST-POINTER-LOWTAG + 4 = OTHER-POINTER-LOWTAG: NIL is both a
-;;; cons and a symbol (at the same address) and depends on this.
-;;; See the definition of SYMBOL in objdef.lisp
+;;; * LIST-POINTER-LOWTAG + N-WORD-BYTES = OTHER-POINTER-LOWTAG: NIL
+;;; is both a cons and a symbol (at the same address) and depends on
+;;; this. See the definition of SYMBOL in objdef.lisp
;;; * OTHER-POINTER-LOWTAG > 4: Some code in the SPARC backend,
;;; which uses bit 2 of the ALLOC register to indicate that
;;; PSEUDO-ATOMIC is on, doesn't strip the low bits of reg_ALLOC
;;; before ORing in OTHER-POINTER-LOWTAG within a PSEUDO-ATOMIC
;;; section.
+;;; * OTHER-IMMEDIATE-n-LOWTAG are spaced 4 apart: various code wants
+;;; to iterate through these.
;;; (These are just the ones we know about as of sbcl-0.7.1.22. There
;;; might easily be more, since these values have stayed highly
;;; constrained for more than a decade, an inviting target for
@@ -42,17 +44,20 @@
;; defined in the first DEFENUM. -- AL 20000216
(defenum (:suffix -lowtag)
even-fixnum
- ;; Note: CMU CL, and SBCL < 0.pre7.39, had FUN-POINTER-LOWTAG
- ;; here. We swapped FUN-POINTER-LOWTAG and
- ;; INSTANCE-POINTER-LOWTAG in sbcl-0.pre7.39 in order to help with a
- ;; low-level pun in the function call sequence on the PPC port.
- ;; For more information, see the PPC port code. -- WHN 2001-10-03
instance-pointer
other-immediate-0
+ pad0
+ pad1
+ pad2
+ other-immediate-1
list-pointer
odd-fixnum
fun-pointer
- other-immediate-1
+ other-immediate-2
+ pad3
+ pad4
+ pad5
+ other-immediate-3
other-pointer))
;;; the heap types, stored in 8 bits of the header of an object on the
@@ -60,7 +65,7 @@
;;; least two machine words, often more)
(defenum (:suffix -widetag
:start (+ (ash 1 n-lowtag-bits) other-immediate-0-lowtag)
- :step (ash 1 (1- n-lowtag-bits)))
+ :step 4)
bignum
ratio
single-float
View
8 src/compiler/generic/early-vm.lisp
@@ -11,7 +11,7 @@
;;; the number of bits at the low end of a pointer used for type
;;; information
-(def!constant n-lowtag-bits 3)
+(def!constant n-lowtag-bits 4)
;;; a mask to extract the low tag bits from a pointer
(def!constant lowtag-mask (1- (ash 1 n-lowtag-bits)))
;;; the exclusive upper bound on the value of the low tag bits from a
@@ -24,9 +24,11 @@
;;; a mask to extract the type from a data block header word
(def!constant widetag-mask (1- (ash 1 n-widetag-bits)))
-(def!constant sb!xc:most-positive-fixnum (1- (ash 1 29))
+(def!constant sb!xc:most-positive-fixnum
+ (1- (ash 1 (- n-word-bits n-lowtag-bits)))
#!+sb-doc
"the fixnum closest in value to positive infinity")
-(def!constant sb!xc:most-negative-fixnum (ash -1 29)
+(def!constant sb!xc:most-negative-fixnum
+ (ash -1 (- n-word-bits n-lowtag-bits))
#!+sb-doc
"the fixnum closest in value to negative infinity")
View
44 src/compiler/generic/genesis.lisp
@@ -186,20 +186,22 @@
(ldb (byte 8 ,(- n 8 (* i 8))) new-value)))))
`(progn
(defun ,name (bigvec byte-index)
- (aver (= sb!vm:n-word-bits 32))
- (aver (= sb!vm:n-byte-bits 8))
+ ;(aver (= sb!vm:n-word-bits 32))
+ ;(aver (= sb!vm:n-byte-bits 8))
(logior ,@(ecase sb!c:*backend-byte-order*
(:little-endian ash-list-le)
(:big-endian ash-list-be))))
(defun (setf ,name) (new-value bigvec byte-index)
- (aver (= sb!vm:n-word-bits 32))
- (aver (= sb!vm:n-byte-bits 8))
+ ;(aver (= sb!vm:n-word-bits 32))
+ ;(aver (= sb!vm:n-byte-bits 8))
(setf ,@(ecase sb!c:*backend-byte-order*
(:little-endian setf-list-le)
(:big-endian setf-list-be))))))))
(make-bvref-n 8)
(make-bvref-n 16)
- (make-bvref-n 32))
+ (make-bvref-n 32)
+ (make-bvref-n 64))
+
;;;; representation of spaces in the core
@@ -294,7 +296,9 @@
(- unsigned #x40000000)
unsigned))))
((or (= lowtag sb!vm:other-immediate-0-lowtag)
- (= lowtag sb!vm:other-immediate-1-lowtag))
+ (= lowtag sb!vm:other-immediate-1-lowtag)
+ (= lowtag sb!vm:other-immediate-2-lowtag)
+ (= lowtag sb!vm:other-immediate-3-lowtag))
(format stream
"for other immediate: #X~X, type #b~8,'0B"
(ash (descriptor-bits des) (- sb!vm:n-widetag-bits))
@@ -350,14 +354,9 @@
(defun descriptor-fixnum (des)
(let ((bits (descriptor-bits des)))
(if (logbitp (1- sb!vm:n-word-bits) bits)
- ;; KLUDGE: The (- SB!VM:N-WORD-BITS 2) term here looks right to
- ;; me, and it works, but in CMU CL it was (1- SB!VM:N-WORD-BITS),
- ;; and although that doesn't make sense for me, or work for me,
- ;; it's hard to see how it could have been wrong, since CMU CL
- ;; genesis worked. It would be nice to understand how this came
- ;; to be.. -- WHN 19990901
- (logior (ash bits -2) (ash -1 (- sb!vm:n-word-bits 2)))
- (ash bits -2))))
+ (logior (ash bits -3) (ash -1 (- sb!vm:n-word-bits 3)))
+ (ash bits -3))))
+
;;; common idioms
(defun descriptor-bytes (des)
@@ -490,7 +489,7 @@
(bytes (gspace-bytes gspace))
(byte-index (ash (+ index (descriptor-word-offset address))
sb!vm:word-shift))
- (value (bvref-32 bytes byte-index)))
+ (value (bvref-64 bytes byte-index)))
(make-random-descriptor value)))
(declaim (ftype (function (descriptor) descriptor) read-memory))
@@ -533,7 +532,7 @@
(let* ((bytes (gspace-bytes (descriptor-intuit-gspace address)))
(byte-index (ash (+ index (descriptor-word-offset address))
sb!vm:word-shift)))
- (setf (bvref-32 bytes byte-index)
+ (setf (bvref-64 bytes byte-index)
(descriptor-bits value)))))
(declaim (ftype (function (descriptor descriptor)) write-memory))
@@ -735,7 +734,7 @@
;;; Copy the given number to the core.
(defun number-to-core (number)
(typecase number
- (integer (if (< (integer-length number) 30)
+ (integer (if (< (integer-length number) 61)
(make-fixnum-descriptor number)
(bignum-to-core number)))
(ratio (number-pair-to-core (number-to-core (numerator number))
@@ -2946,11 +2945,11 @@ initially undefined function references:~2%")
(defun write-word (num)
(ecase sb!c:*backend-byte-order*
(:little-endian
- (dotimes (i 4)
+ (dotimes (i 8)
(write-byte (ldb (byte 8 (* i 8)) num) *core-file*)))
(:big-endian
- (dotimes (i 4)
- (write-byte (ldb (byte 8 (* (- 3 i) 8)) num) *core-file*))))
+ (dotimes (i 8)
+ (write-byte (ldb (byte 8 (* (- 7 i) 8)) num) *core-file*))))
num)
(defun advance-to-page ()
@@ -2969,10 +2968,11 @@ initially undefined function references:~2%")
(file-position *core-file*
(* sb!c:*backend-page-size* (1+ *data-page*)))
(format t
- "writing ~S byte~:P [~S page~:P] from ~S~%"
+ "writing ~S byte~:P [~S page~:P] from ~S (start 0x~X)~%"
total-bytes
pages
- gspace)
+ gspace
+ (gspace-byte-address gspace))
(force-output)
;; Note: It is assumed that the GSPACE allocation routines always
View
3  src/compiler/generic/late-type-vops.lisp
@@ -15,8 +15,7 @@
;; we can save a register on the x86.
:variant simple
;; we can save a couple of instructions and a branch on the ppc.
- ;; FIXME: make this be FIXNUM-MASK
- :mask 3)
+ :mask (ash lowtag-mask -1))
(!define-type-vops functionp check-fun function object-not-fun-error
(fun-pointer-lowtag)
View
40 src/compiler/generic/objdef.lisp
@@ -51,7 +51,7 @@
(define-primitive-object (bignum :lowtag other-pointer-lowtag
:widetag bignum-widetag
:alloc-trans sb!bignum::%allocate-bignum)
- (digits :rest-p t :c-type #!-alpha "long" #!+alpha "u32"))
+ (digits :rest-p t :c-type #!-alpha32 "long" #!+alpha32 "u32"))
(define-primitive-object (ratio :type ratio
:lowtag other-pointer-lowtag
@@ -133,7 +133,7 @@
:widetag t)
(length :ref-trans sb!c::vector-length
:type index)
- (data :rest-p t :c-type #!-alpha "unsigned long" #!+alpha "u32"))
+ (data :rest-p t :c-type #!-alpha32 "unsigned long" #!+alpha32 "u32"))
(define-primitive-object (code :type code-component
:lowtag other-pointer-lowtag
@@ -159,7 +159,7 @@
:widetag fdefn-widetag)
(name :ref-trans fdefn-name)
(fun :type (or function null) :ref-trans fdefn-fun)
- (raw-addr :c-type #!-alpha "char *" #!+alpha "u32"))
+ (raw-addr :c-type #!-alpha32 "char *" #!+alpha32 "u32"))
;;; a simple function (as opposed to hairier things like closures
;;; which are also subtypes of Common Lisp's FUNCTION type)
@@ -259,13 +259,13 @@
:ref-known (flushable)
:init :arg))
-#!+alpha
+#!+alpha32
(define-primitive-object (sap :lowtag other-pointer-lowtag
:widetag sap-widetag)
(padding)
(pointer :c-type "char *" :length 2))
-#!-alpha
+#!-alpha32
(define-primitive-object (sap :lowtag other-pointer-lowtag
:widetag sap-widetag)
(pointer :c-type "char *"))
@@ -280,7 +280,7 @@
(broken :type (member t nil)
:ref-trans sb!c::%weak-pointer-broken :ref-known (flushable)
:init :null)
- (next :c-type #!-alpha "struct weak_pointer *" #!+alpha "u32"))
+ (next :c-type #!-alpha32 "struct weak_pointer *" #!+alpha32 "u32"))
;;;; other non-heap data blocks
@@ -289,18 +289,18 @@
symbol)
(define-primitive-object (unwind-block)
- (current-uwp :c-type #!-alpha "struct unwind_block *" #!+alpha "u32")
- (current-cont :c-type #!-alpha "lispobj *" #!+alpha "u32")
+ (current-uwp :c-type #!-alpha32 "struct unwind_block *" #!+alpha32 "u32")
+ (current-cont :c-type #!-alpha32 "lispobj *" #!+alpha32 "u32")
#!-x86 current-code
entry-pc)
(define-primitive-object (catch-block)
- (current-uwp :c-type #!-alpha "struct unwind_block *" #!+alpha "u32")
- (current-cont :c-type #!-alpha "lispobj *" #!+alpha "u32")
+ (current-uwp :c-type #!-alpha32 "struct unwind_block *" #!+alpha32 "u32")
+ (current-cont :c-type #!-alpha32 "lispobj *" #!+alpha32 "u32")
#!-x86 current-code
entry-pc
tag
- (previous-catch :c-type #!-alpha "struct catch_block *" #!+alpha "u32")
+ (previous-catch :c-type #!-alpha32 "struct catch_block *" #!+alpha32 "u32")
size)
;;; (For an explanation of this, see the comments at the definition of
@@ -370,18 +370,18 @@
;; pass the address of initial-function into new_thread_trampoline
(unbound-marker :init :unbound) ; tls[0] = UNBOUND_MARKER_WIDETAG
(pid :c-type "pid_t")
- (binding-stack-start :c-type "lispobj *" :length #!+alpha 2 #!-alpha 1)
- (binding-stack-pointer :c-type "lispobj *" :length #!+alpha 2 #!-alpha 1)
- (control-stack-start :c-type "lispobj *" :length #!+alpha 2 #!-alpha 1)
- (control-stack-end :c-type "lispobj *" :length #!+alpha 2 #!-alpha 1)
- (alien-stack-start :c-type "lispobj *" :length #!+alpha 2 #!-alpha 1)
- (alien-stack-pointer :c-type "lispobj *" :length #!+alpha 2 #!-alpha 1)
+ (binding-stack-start :c-type "lispobj *" :length #!+alpha32 2 #!-alpha32 1)
+ (binding-stack-pointer :c-type "lispobj *" :length #!+alpha32 2 #!-alpha32 1)
+ (control-stack-start :c-type "lispobj *" :length #!+alpha32 2 #!-alpha32 1)
+ (control-stack-end :c-type "lispobj *" :length #!+alpha32 2 #!-alpha32 1)
+ (alien-stack-start :c-type "lispobj *" :length #!+alpha32 2 #!-alpha32 1)
+ (alien-stack-pointer :c-type "lispobj *" :length #!+alpha32 2 #!-alpha32 1)
#!+gencgc (alloc-region :c-type "struct alloc_region" :length 5)
(tls-cookie) ; on x86, the LDT index
- (this :c-type "struct thread *" :length #!+alpha 2 #!-alpha 1)
- (next :c-type "struct thread *" :length #!+alpha 2 #!-alpha 1)
+ (this :c-type "struct thread *" :length #!+alpha32 2 #!-alpha32 1)
+ (next :c-type "struct thread *" :length #!+alpha32 2 #!-alpha32 1)
#!+x86 (pseudo-atomic-atomic)
#!+x86 (pseudo-atomic-interrupted)
(interrupt-data :c-type "struct interrupt_data *"
- :length #!+alpha 2 #!-alpha 1)
+ :length #!+alpha32 2 #!-alpha32 1)
(interrupt-contexts :c-type "os_context_t *" :rest-p t))
View
33 src/compiler/generic/primtype.lisp
@@ -23,7 +23,7 @@
;;; primitive integer types that fit in registers
(/show0 "primtype.lisp 24")
(!def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg)
- :type (unsigned-byte 29))
+ :type (unsigned-byte 60))
(/show0 "primtype.lisp 27")
#!-alpha
(!def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg)
@@ -40,7 +40,7 @@
(!def-primitive-type unsigned-byte-64 (unsigned-reg descriptor-reg)
:type (unsigned-byte 64))
(!def-primitive-type fixnum (any-reg signed-reg)
- :type (signed-byte 30))
+ :type (signed-byte 61))
#!-alpha
(!def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
:type (signed-byte 32))
@@ -104,8 +104,9 @@
:type (simple-array nil (*)))
(!def-primitive-type simple-string (descriptor-reg)
:type simple-base-string)
-(!def-primitive-type simple-bit-vector (descriptor-reg))
(!def-primitive-type simple-vector (descriptor-reg))
+
+(!def-primitive-type simple-bit-vector (descriptor-reg))
(!def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg)
:type (simple-array (unsigned-byte 2) (*)))
(!def-primitive-type simple-array-unsigned-byte-4 (descriptor-reg)
@@ -116,6 +117,9 @@
:type (simple-array (unsigned-byte 16) (*)))
(!def-primitive-type simple-array-unsigned-byte-32 (descriptor-reg)
:type (simple-array (unsigned-byte 32) (*)))
+(!def-primitive-type simple-array-unsigned-byte-64 (descriptor-reg)
+ :type (simple-array (unsigned-byte 64) (*)))
+
(!def-primitive-type simple-array-signed-byte-8 (descriptor-reg)
:type (simple-array (signed-byte 8) (*)))
(!def-primitive-type simple-array-signed-byte-16 (descriptor-reg)
@@ -124,6 +128,11 @@
:type (simple-array (signed-byte 30) (*)))
(!def-primitive-type simple-array-signed-byte-32 (descriptor-reg)
:type (simple-array (signed-byte 32) (*)))
+(!def-primitive-type simple-array-signed-byte-61 (descriptor-reg)
+ :type (simple-array (signed-byte 61) (*)))
+(!def-primitive-type simple-array-signed-byte-64 (descriptor-reg)
+ :type (simple-array (signed-byte 64) (*)))
+
(!def-primitive-type simple-array-single-float (descriptor-reg)
:type (simple-array single-float (*)))
(!def-primitive-type simple-array-double-float (descriptor-reg)
@@ -170,10 +179,12 @@
((unsigned-byte 8) . simple-array-unsigned-byte-8)
((unsigned-byte 16) . simple-array-unsigned-byte-16)
((unsigned-byte 32) . simple-array-unsigned-byte-32)
+ ((unsigned-byte 64) . simple-array-unsigned-byte-64)
((signed-byte 8) . simple-array-signed-byte-8)
((signed-byte 16) . simple-array-signed-byte-16)
- (fixnum . simple-array-signed-byte-30)
((signed-byte 32) . simple-array-signed-byte-32)
+ (fixnum . simple-array-signed-byte-61)
+ ((signed-byte 64) . simple-array-signed-byte-64)
(single-float . simple-array-single-float)
(double-float . simple-array-double-float)
#!+long-float (long-float . simple-array-long-float)
@@ -254,7 +265,7 @@
(integer
(cond ((and hi lo)
(dolist (spec
- `((positive-fixnum 0 ,(1- (ash 1 29)))
+ `((positive-fixnum 0 ,sb!xc:most-positive-fixnum)
#!-alpha
(unsigned-byte-31 0 ,(1- (ash 1 31)))
#!-alpha
@@ -263,16 +274,16 @@
(unsigned-byte-63 0 ,(1- (ash 1 63)))
#!+alpha
(unsigned-byte-64 0 ,(1- (ash 1 64)))
- (fixnum ,(ash -1 29)
- ,(1- (ash 1 29)))
+ (fixnum ,sb!xc:most-negative-fixnum
+ ,sb!xc:most-positive-fixnum)
#!-alpha
(signed-byte-32 ,(ash -1 31)
,(1- (ash 1 31)))
#!+alpha
(signed-byte-64 ,(ash -1 63)
,(1- (ash 1 63))))
- (if (or (< hi (ash -1 29))
- (> lo (1- (ash 1 29))))
+ (if (or (< hi sb!xc:most-negative-fixnum)
+ (> lo sb!xc:most-positive-fixnum))
(part-of bignum)
(any)))
(let ((type (car spec))
@@ -282,8 +293,8 @@
(return (values
(primitive-type-or-lose type)
(and (= lo min) (= hi max))))))))
- ((or (and hi (< hi most-negative-fixnum))
- (and lo (> lo most-positive-fixnum)))
+ ((or (and hi (< hi sb!xc:most-negative-fixnum))
+ (and lo (> lo sb!xc:most-positive-fixnum)))
(part-of bignum))
(t
(any))))
View
7 src/compiler/generic/utils.lisp
@@ -12,10 +12,11 @@
(in-package "SB!VM")
-;;; Make a fixnum out of NUM. (I.e. shift by two bits if it will fit.)
+;;; Return an integer which when used as a raw machine word will have
+;;; the same bit pattern as the fixnum NUM.
(defun fixnumize (num)
- (if (<= #x-20000000 num #x1fffffff)
- (ash num 2)
+ (if (fixnump num)
+ (ash num (1- n-lowtag-bits))
(error "~W is too big for a fixnum." num)))
;;;; routines for dealing with static symbols
View
8 src/compiler/generic/vm-fndb.lisp
@@ -117,9 +117,9 @@
(complex long-float)
(unsafe))
-(defknown %raw-bits (t fixnum) (unsigned-byte 32)
+(defknown %raw-bits (t fixnum) (unsigned-byte 64)
(foldable flushable))
-(defknown (%set-raw-bits) (t fixnum (unsigned-byte 32)) (unsigned-byte 32)
+(defknown (%set-raw-bits) (t fixnum (unsigned-byte 64)) (unsigned-byte 64)
(unsafe))
@@ -153,8 +153,8 @@
(defknown %set-stack-ref (system-area-pointer index t) t (unsafe))
(defknown lra-code-header (t) t (movable flushable))
(defknown fun-code-header (t) t (movable flushable))
-(defknown make-lisp-obj ((unsigned-byte 32)) t (movable flushable))
-(defknown get-lisp-obj-address (t) (unsigned-byte 32) (movable flushable))
+(defknown make-lisp-obj ((unsigned-byte 64)) t (movable flushable))
+(defknown get-lisp-obj-address (t) (unsigned-byte 64) (movable flushable))
(defknown fun-word-offset (function) index (movable flushable))
;;;; 32-bit logical operations
View
2  src/compiler/generic/vm-type.lisp
@@ -37,7 +37,7 @@
`(single-float ,low ,high))
;;; an index into an integer
-(sb!xc:deftype bit-index () `(integer 0 ,most-positive-fixnum))
+(sb!xc:deftype bit-index () `(integer 0 ,sb!xc:most-positive-fixnum))
;;; worst-case values for float attributes
(sb!xc:deftype float-exponent ()
View
5 src/compiler/globaldb.lisp
@@ -67,8 +67,9 @@
(let ((rest (rest x)))
(and (symbolp (car rest))
(null (cdr rest)))))
- (logxor (symbol-hash (second x))
- 110680597))
+ (logand 536870911
+ (logxor (symbol-hash (second x))
+ 110680597)))
(t (sxhash x))))
;;; Given any non-negative integer, return a prime number >= to it.
View
72 src/runtime/alpha-assem.S
@@ -49,24 +49,24 @@ call_into_lisp:
.frame sp,framesize,ra
/* Clear descriptor regs */
- ldil reg_CODE,0
- ldil reg_FDEFN,0
+ ldiq reg_CODE,0
+ ldiq reg_FDEFN,0
mov a0,reg_LEXENV
- sll a2,2,reg_NARGS
- ldil reg_OCFP,0
- ldil reg_LRA,0
- ldil reg_L0,0
- ldil reg_L1,0
+ sll a2,3,reg_NARGS
+ ldiq reg_OCFP,0
+ ldiq reg_LRA,0
+ ldiq reg_L0,0
+ ldiq reg_L1,0
/* Establish NIL. */
- ldil reg_NULL,NIL
+ ldiq reg_NULL,NIL
/* The CMUCL comment here is "Start pseudo-atomic.", but */
/* there's no obvious code that would have that effect */
/* No longer in foreign call. */
- stl zero,foreign_function_call_active
+ stq zero,foreign_function_call_active
/* Load lisp state. */
ldq reg_ALLOC,dynamic_space_free_pointer
@@ -76,25 +76,25 @@ call_into_lisp:
mov a1,reg_CFP
.set noat
- ldil reg_L2,0
+ ldiq reg_L2,0
.set at
/* End of pseudo-atomic. */
/* Establish lisp arguments. */
- ldl reg_A0,0(reg_CFP)
- ldl reg_A1,4(reg_CFP)
- ldl reg_A2,8(reg_CFP)
- ldl reg_A3,12(reg_CFP)
- ldl reg_A4,16(reg_CFP)
- ldl reg_A5,20(reg_CFP)
+ ldq reg_A0,0(reg_CFP)
+ ldq reg_A1,8(reg_CFP)
+ ldq reg_A2,16(reg_CFP)
+ ldq reg_A3,24(reg_CFP)
+ ldq reg_A4,32(reg_CFP)
+ ldq reg_A5,40(reg_CFP)
/* This call will 'return' into the LRA page below */
lda reg_LRA,call_into_lisp_LRA_page+OTHER_POINTER_LOWTAG
/* Indirect the closure */
- ldl reg_CODE, CLOSURE_FUN_OFFSET(reg_LEXENV)
- addl reg_CODE,6*4-FUN_POINTER_LOWTAG, reg_LIP
+ ldq reg_CODE, CLOSURE_FUN_OFFSET(reg_LEXENV)
+ addq reg_CODE,6*8-FUN_POINTER_LOWTAG, reg_LIP
/* And into lisp we go. */
jsr reg_ZERO,(reg_LIP)
@@ -126,7 +126,7 @@ call_into_lisp_LRA:
stq reg_CFP,current_control_frame_pointer
/* Back in C land. [CSP is just a handy non-zero value.] */
- stl reg_CSP,foreign_function_call_active
+ stq reg_CSP,foreign_function_call_active
/* Turn off pseudo-atomic and check for traps. */
@@ -162,13 +162,13 @@ call_into_c:
.frame sp,12,ra
mov reg_CFP, reg_OCFP
mov reg_CSP, reg_CFP
- addq reg_CFP, 32, reg_CSP
- stl reg_OCFP, 0(reg_CFP)
+ addq reg_CFP, 64, reg_CSP
+ stq reg_OCFP, 0(reg_CFP)
subl reg_LIP, reg_CODE, reg_L1
addl reg_L1, OTHER_POINTER_LOWTAG, reg_L1
- stl reg_L1, 4(reg_CFP)
- stl reg_CODE, 8(reg_CFP)
- stl reg_NULL, 12(reg_CFP)
+ stq reg_L1, 8(reg_CFP)
+ stq reg_CODE, 16(reg_CFP)
+ stq reg_NULL, 24(reg_CFP)
/* Set the pseudo-atomic flag. */
addq reg_ALLOC,1,reg_ALLOC
@@ -187,11 +187,11 @@ call_into_c:
stq reg_CFP, current_control_frame_pointer
/* Mark us as in C land. */
- stl reg_CSP, foreign_function_call_active
+ stq reg_CSP, foreign_function_call_active
/* Were we interrupted? */
subq reg_ALLOC,1,reg_ALLOC
- stl reg_ZERO,0(reg_ALLOC)
+ stq reg_ZERO,0(reg_ALLOC)
/* Into C land we go. */
@@ -220,7 +220,7 @@ call_into_c:
lda reg_ALLOC,1(reg_ZERO)
/* Mark us at in Lisp land. */
- stl reg_ZERO, foreign_function_call_active
+ stq reg_ZERO, foreign_function_call_active
/* Restore ALLOC, preserving pseudo-atomic-atomic */
ldq reg_NL0,dynamic_space_free_pointer
@@ -228,14 +228,14 @@ call_into_c:
/* Check for interrupt */
subq reg_ALLOC,1,reg_ALLOC
- stl reg_ZERO,0(reg_ALLOC)
+ stq reg_ZERO,0(reg_ALLOC)
- ldl reg_NULL, 12(reg_CFP)
+ ldq reg_NULL, 24(reg_CFP)
/* Restore LRA & CODE (they may have been GC'ed) */
/* can you see anything here which touches LRA? I can't ...*/
- ldl reg_CODE, 8(reg_CFP)
- ldl reg_NL0, 4(reg_CFP)
+ ldq reg_CODE, 16(reg_CFP)
+ ldq reg_NL0, 8(reg_CFP)
subq reg_NL0, OTHER_POINTER_LOWTAG, reg_NL0
addq reg_CODE, reg_NL0, reg_NL0
@@ -287,9 +287,9 @@ undefined_tramp= call_into_lisp_LRA_page+0x140
.ent closure_tramp_offset
closure_tramp= call_into_lisp_LRA_page+0x150
closure_tramp_offset:
- ldl reg_LEXENV, FDEFN_FUN_OFFSET(reg_FDEFN)
- ldl reg_L0, CLOSURE_FUN_OFFSET(reg_LEXENV)
- addl reg_L0, SIMPLE_FUN_CODE_OFFSET, reg_LIP
+ ldq reg_LEXENV, FDEFN_FUN_OFFSET(reg_FDEFN)
+ ldq reg_L0, CLOSURE_FUN_OFFSET(reg_LEXENV)
+ addq reg_L0, SIMPLE_FUN_CODE_OFFSET, reg_LIP
jmp reg_ZERO,(reg_LIP)
.end closure_tramp_offset
@@ -311,8 +311,8 @@ fun_end_breakpoint_guts:
br zero, fun_end_breakpoint_trap
nop
mov reg_CSP, reg_OCFP
- addl reg_CSP, 4, reg_CSP
- addl zero, 4, reg_NARGS
+ addq reg_CSP, 8, reg_CSP
+ addq zero, 8, reg_NARGS
mov reg_NULL, reg_A1
mov reg_NULL, reg_A2
mov reg_NULL, reg_A3
View
14 src/runtime/backtrace.c
@@ -34,28 +34,16 @@
* better not change. */
struct call_frame {
-#ifndef alpha
struct call_frame *old_cont;
-#else
- u32 old_cont;
-#endif
lispobj saved_lra;
lispobj code;
lispobj other_state[5];
};
struct call_info {
-#ifndef alpha
struct call_frame *frame;
-#else
- u32 frame;
-#endif
int interrupted;
-#ifndef alpha
struct code *code;
-#else
- u32 code;
-#endif
lispobj lra;
int pc; /* Note: this is the trace file offset, not the actual pc. */
};
@@ -171,7 +159,7 @@ previous_info(struct call_info *info)
if (info->lra == NIL) {
/* We were interrupted. Find the correct signal context. */
- free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread)>>2;
+ free = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread));
while (free-- > 0) {
os_context_t *context =
thread->interrupt_contexts[free];
View
2  src/runtime/cheneygc.c
@@ -527,7 +527,7 @@ scav_fdefn(lispobj *where, lispobj object)
== (char *)((unsigned long)(fdefn->raw_addr))) {
scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
fdefn->raw_addr =
- (u32) ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET;
+ ((char *) LOW_WORD(fdefn->fun)) + FUN_RAW_ADDR_OFFSET;
return sizeof(struct fdefn) / sizeof(lispobj);
}
else
View
8 src/runtime/core.h
@@ -15,19 +15,11 @@
#include "runtime.h"
struct ndir_entry {
-#ifndef alpha
long identifier;
long nwords;
long data_page;
long address;
long page_count;
-#else
- u32 identifier;
- u32 nwords;
- u32 data_page;
- u32 address;
- u32 page_count;
-#endif
};
extern lispobj load_core_file(char *file);
View
9 src/runtime/coreparse.c
@@ -38,6 +38,8 @@
unsigned char build_id[] =
#include "../../output/build-id.tmp"
;
+#define FSHOW(c) fprintf c
+#define SHOW(c) fprintf(stderr,"%s\n",c)
static void
process_directory(int fd, u32 *ptr, int count)
@@ -126,7 +128,7 @@ process_directory(int fd, u32 *ptr, int count)
lispobj
load_core_file(char *file)
{
- u32 *header, val, len, *ptr, remaining_len;
+ unsigned long *header, val, len, *ptr, remaining_len;
int fd = open(file, O_RDONLY), count;
lispobj initial_function = NIL;
@@ -211,13 +213,8 @@ load_core_file(char *file)
SHOW("NEW_DIRECTORY_CORE_ENTRY_TYPE_CODE case");
process_directory(fd,
ptr,
-#ifndef alpha
remaining_len / (sizeof(struct ndir_entry) /
sizeof(long))
-#else
- remaining_len / (sizeof(struct ndir_entry) /
- sizeof(u32))
-#endif
);
break;
View
2  src/runtime/gc-common.c
@@ -715,7 +715,7 @@ scav_fdefn(lispobj *where, lispobj object)
/* gc.c has more casts here, which may be relevant or alternatively
may be compiler warning defeaters. try