common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

0.8.15.14.x86-64-again-branch.34:

Browse source 
* Fix some probable 32-bit Alpha problems that were introduced
          earlier during the port in primtype, sb-sprof and run-program.
	* Use a more space-efficient boxed presentation for double-floats
          and complex double-floats.
        * Add VOP for non-constant modular left shifts (added to
          other archs after the AMD64 port was originally started).
        * Add a REX-prefix for XCHG.
        * Implement inline allocation.
        * More int -> long in gencgc.
        * Only scan pages up to last_free_page instead of NUM_PAGES in
          update_x86_dynamic_space_free_pointer() (otherwise GC is
          ridiculously slow with large dynamic spaces).
This commit is contained in:
Juho Snellman 2004-12-14 02:31:34 +00:00
parent 13dd2e09f8
commit cc7aa69d4e
10 changed files with 138 additions and 56 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
contrib/sb-sprof/sb-sprof.lisp
View file

@ -423,7 +423,7 @@
(deftype address ()
"Type used for addresses, for instance, program counters,
code start/end locations etc."
'sb-vm::word)
'(unsigned-byte #.sb-vm::n-machine-word-bits))
(defconstant +unknown-address+ 0
"Constant representing an address that cannot be determined.")

3
src/code/run-program.lisp
View file

@ -331,7 +331,8 @@
(let ((string-bytes 0)
;; We need an extra for the null, and an extra 'cause exect
;; clobbers argv[-1].
(vec-bytes (* sb-vm::n-word-bytes (+ (length string-list) 2))))
(vec-bytes (* #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits)
(+ (length string-list) 2))))
(declare (fixnum string-bytes vec-bytes))
(dolist (s string-list)
(enforce-type s simple-string)

10
src/compiler/generic/objdef.lisp
View file

@ -72,8 +72,8 @@
(define-primitive-object (double-float :lowtag other-pointer-lowtag
:widetag double-float-widetag)
(filler)
(value :c-type "double" :length 2))
#!-x86-64 (filler)
(value :c-type "double" :length #!-x86-64 2 #!+x86-64 1))
#!+long-float
(define-primitive-object (long-float :lowtag other-pointer-lowtag
@ -350,9 +350,9 @@
(define-primitive-object (complex-double-float
:lowtag other-pointer-lowtag
:widetag complex-double-float-widetag)
(filler)
(real :c-type "double" :length 2)
(imag :c-type "double" :length 2))
#!-x86-64 (filler)
(real :c-type "double" :length #!-x86-64 2 #!+x86-64 1)
(imag :c-type "double" :length #!-x86-64 2 #!+x86-64 1))
;;; this isn't actually a lisp object at all, it's a c structure that lives
;;; in c-land. However, we need sight of so many parts of it from Lisp that

105
src/compiler/generic/primtype.lisp
View file

@ -25,26 +25,27 @@
(!def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg)
:type (unsigned-byte #.sb!vm:n-positive-fixnum-bits))
(/show0 "primtype.lisp 27")
#!-x86-64
#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 32) '(and) '(or))
(!def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg)
:type (unsigned-byte 31))
(/show0 "primtype.lisp 31")
#!-x86-64
#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 32) '(and) '(or))
(!def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg)
:type (unsigned-byte 32))
(/show0 "primtype.lisp 35")
#!+x86-64
#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
(!def-primitive-type unsigned-byte-63 (signed-reg unsigned-reg descriptor-reg)
:type (unsigned-byte 63))
#!+x86-64
#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
(!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 #.(1+ sb!vm:n-positive-fixnum-bits)))
; #!-x86-64
;; x86-64 needs a signed-byte-32 for proper handling of c-call return values.
#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or x86-64))
(!def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
:type (signed-byte 32))
#!+x86-64
#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
(!def-primitive-type signed-byte-64 (signed-reg descriptor-reg)
:type (signed-byte 64))
@ -157,32 +158,48 @@
(case t1-name
(positive-fixnum
(if (or (eq t2-name 'fixnum)
(eq t2-name #!-x86-64 'signed-byte-32
#!+x86-64 'signed-byte-64)
(eq t2-name #!-x86-64 'unsigned-byte-31
#!+x86-64 'unsigned-byte-63)
(eq t2-name #!-x86-64 'unsigned-byte-32
#!+x86-64 'unsigned-byte-64))
(eq t2-name
(ecase sb!vm::n-machine-word-bits
(32 'signed-byte-32)
(64 'signed-byte-64)))
(eq t2-name
(ecase sb!vm::n-machine-word-bits
(32 'unsigned-byte-31)
(64 'unsigned-byte-63)))
(eq t2-name
(ecase sb!vm::n-machine-word-bits
(32 'unsigned-byte-32)
(64 'unsigned-byte-64))))
t2))
(fixnum
(case t2-name
(#!-x86-64 signed-byte-32
#!+x86-64 signed-byte-64 t2)
(#!-x86-64 unsigned-byte-31
#!+x86-64 unsigned-byte-63
(primitive-type-or-lose
#!-x86-64 'signed-byte-32
#!+x86-64 'signed-byte-64))))
(#!-x86-64 signed-byte-32
#!+x86-64 signed-byte-64
(if (eq t2-name #!-x86-64 'unsigned-byte-31
#!+x86-64 'unsigned-byte-63)
(#.(ecase sb!vm::n-machine-word-bits
(32 'signed-byte-32)
(64 'signed-byte-64))
t2)
(#.(ecase sb!vm::n-machine-word-bits
(32 'unsigned-byte-31)
(64 'unsigned-byte-63))
(primitive-type-or-lose
(ecase sb!vm::n-machine-word-bits
(32 'signed-byte-32)
(64 'signed-byte-64))))))
(#.(ecase sb!vm::n-machine-word-bits
(32 'signed-byte-32)
(64 'signed-byte-64))
(if (eq t2-name
(ecase sb!vm::n-machine-word-bits
(32 'unsigned-byte-31)
(64 'unsigned-byte-63)))
t1))
(#!-x86-64 unsigned-byte-31
#!+x86-64 unsigned-byte-63
(if (eq t2-name #!-x86-64 'unsigned-byte-32
#!+x86-64 'unsigned-byte-64)
t2))))))
(#.(ecase sb!vm::n-machine-word-bits
(32 'unsigned-byte-31)
(64 'unsigned-byte-63))
(if (eq t2-name
(ecase sb!vm::n-machine-word-bits
(32 'unsigned-byte-32)
(64 'unsigned-byte-64)))
t2))))))
(etypecase type
(numeric-type
(let ((lo (numeric-type-low type))
@ -194,22 +211,26 @@
(cond ((and hi lo)
(dolist (spec
`((positive-fixnum 0 ,sb!xc:most-positive-fixnum)
#!-x86-64
(unsigned-byte-31 0 ,(1- (ash 1 31)))
#!-x86-64
(unsigned-byte-32 0 ,(1- (ash 1 32)))
#!+x86-64
(unsigned-byte-63 0 ,(1- (ash 1 63)))
#!+x86-64
(unsigned-byte-64 0 ,(1- (ash 1 64)))
,@(ecase sb!vm::n-machine-word-bits
(32
`((unsigned-byte-31
0 ,(1- (ash 1 31)))
(unsigned-byte-32
0 ,(1- (ash 1 32)))))
(64
`((unsigned-byte-63
0 ,(1- (ash 1 63)))
(unsigned-byte-64
0 ,(1- (ash 1 64))))))
(fixnum ,sb!xc:most-negative-fixnum
,sb!xc:most-positive-fixnum)
#!-x86-64
(signed-byte-32 ,(ash -1 31)
,(1- (ash 1 31)))
#!+x86-64
(signed-byte-64 ,(ash -1 63)
,(1- (ash 1 63))))
,(ecase sb!vm::n-machine-word-bits
(32
`(signed-byte-32 ,(ash -1 31)
,(1- (ash 1 31))))
(64
`(signed-byte-64 ,(ash -1 63)
,(1- (ash 1 63))))))
(if (or (< hi sb!xc:most-negative-fixnum)
(> lo sb!xc:most-positive-fixnum))
(part-of bignum)

7
src/compiler/x86-64/arith.lisp
View file

@ -1253,6 +1253,13 @@
(define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
fast-ash-c/unsigned=>unsigned)
(:translate ash-left-mod64))
(define-vop (fast-ash-left-mod64/unsigned=>unsigned
fast-ash-left/unsigned=>unsigned))
(deftransform ash-left-mod64 ((integer count)
((unsigned-byte 64) (unsigned-byte 6)))
(when (sb!c::constant-lvar-p count)
(sb!c::give-up-ir1-transform))
'(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
(in-package "SB!C")

1
src/compiler/x86-64/insts.lisp
View file

@ -1382,6 +1382,7 @@
(reg-tn-encoding something)))
(xchg-reg-with-something acc something)))
(xchg-reg-with-something (reg something)
(maybe-emit-rex-for-ea segment something reg)
(emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
(emit-ea segment something (reg-tn-encoding reg))))
(cond ((accumulator-p operand1)

52
src/compiler/x86-64/macros.lisp
View file

@ -153,6 +153,58 @@
;;; This macro should only be used inside a pseudo-atomic section,
;;; which should also cover subsequent initialization of the
;;; object.
(defun allocation-tramp (alloc-tn size &optional ignored)
(declare (ignore ignored))
(inst push size)
(inst lea r13-tn (make-ea :qword
:disp (make-fixup (extern-alien-name "alloc_tramp")
:foreign)))
(inst call r13-tn)
(inst pop alloc-tn)
(values))
(defun allocation (alloc-tn size &optional ignored)
(declare (ignore ignored))
(let ((not-inline (gen-label))
(done (gen-label))
;; Yuck.
(in-elsewhere (eq *elsewhere* sb!assem::**current-segment**))
(free-pointer
(make-ea :qword :disp
#!+sb-thread (* n-word-bytes thread-alloc-region-slot)
#!-sb-thread (make-fixup (extern-alien-name "boxed_region")
:foreign)
:scale 1)) ; thread->alloc_region.free_pointer
(end-addr
(make-ea :qword :disp
#!+sb-thread (* n-word-bytes (1+ thread-alloc-region-slot))
#!-sb-thread (make-fixup (extern-alien-name "boxed_region")
:foreign 8)
:scale 1))) ; thread->alloc_region.end_addr
(cond (in-elsewhere
(allocation-tramp alloc-tn size))
(t
(unless (and (tn-p size) (location= alloc-tn size))
(inst mov alloc-tn size))
#!+sb-thread (inst fs-segment-prefix)
(inst add alloc-tn free-pointer)
#!+sb-thread (inst fs-segment-prefix)
(inst cmp end-addr alloc-tn)
(inst jmp :be NOT-INLINE)
#!+sb-thread (inst fs-segment-prefix)
(inst xchg free-pointer alloc-tn)
(emit-label DONE)
(assemble (*elsewhere*)
(emit-label NOT-INLINE)
(cond ((numberp size)
(allocation-tramp alloc-tn size))
(t
(inst sub alloc-tn free-pointer)
(allocation-tramp alloc-tn alloc-tn)))
(inst jmp DONE))
(values)))))
#+nil
(defun allocation (alloc-tn size &optional ignored)
(declare (ignore ignored))
(inst push size)

6
src/runtime/gencgc-alloc-region.h
View file

@ -9,14 +9,14 @@ struct alloc_region {
void *end_addr; /* pointer to the byte after the last usable byte */
/* These are needed when closing the region. */
int first_page;
int last_page;
long first_page;
long last_page;
void *start_addr;
};
extern struct alloc_region boxed_region;
extern struct alloc_region unboxed_region;
extern int from_space, new_space;
extern long from_space, new_space;
extern struct weak_pointer *weak_pointers;
extern void *current_region_free_pointer;

6
src/runtime/gencgc.c
View file

@ -141,8 +141,8 @@ unsigned long auto_gc_trigger = 0;
/* the source and destination generations. These are set before a GC starts
* scavenging. */
int from_space;
int new_space;
long from_space;
long new_space;
/* An array of page structures is statically allocated.
@ -3734,7 +3734,7 @@ update_x86_dynamic_space_free_pointer(void)
long last_page = -1;
long i;
for (i = 0; i < NUM_PAGES; i++)
for (i = 0; i < last_free_page; i++)
if ((page_table[i].allocated != FREE_PAGE_FLAG)
&& (page_table[i].bytes_used != 0))
last_page = i;

2
version.lisp-expr
View file

@ -17,4 +17,4 @@
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
"0.8.15.14.x86-64-again-branch.33"
"0.8.15.14.x86-64-again-branch.34"