/[cmucl]/src/code/dfixnum.lisp
ViewVC logotype

Contents of /src/code/dfixnum.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Wed Feb 12 18:35:29 2003 UTC (11 years, 2 months ago) by cracauer
Branch: MAIN
CVS Tags: double-double-array-base, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, unicode-string-buffer-base, sse2-packed-base, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, release-19c-base, label-2009-03-16, release-19f-base, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2007-06, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, double-double-init-x86, sse2-checkpoint-2008-10-01, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, unicode-string-buffer-branch, dynamic-extent, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.2: +38 -11 lines
Fix a problem with the consing-free allocation counter.  If you
allocate more than most-positive-fixnum bytes between two GCs, do a
normal, possibly consing addition instead of the fast dfixnum
increment.

Also clean up the exports of the dfixnum package and define a new
operator to increment a dfixnum by any integer.

Tested: full ITA testsuite, tried the profiler, tried various
allocation patterns which failed before this fix.
1 ;;; -*- Package: dfixnum -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project
5 ;;; and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/dfixnum.lisp,v 1.3 2003/02/12 18:35:29 cracauer Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;;
13 ;;; Description: A skeleton of a package to do consing-free arithmetic on
14 ;;; integers using two fixnums. One bit in each fixnum is used for internal
15 ;;; calculations, so a 32-bit Lisp implementation with two-bit tags will
16 ;;; have 56 bit range in this package (54 bits unsigned).
17 ;;;
18 ;;; NOTE: this package is extremly raw and only supports what is needed for
19 ;;; the profiler. It should be considered an interface specification with
20 ;;; a partial sketchy implentation.
21 ;;;
22 ;;; Author: Martin Cracauer
23 ;;;
24 ;;; Compatibility: Runs in any valid Common Lisp.
25
26 (defpackage "DFIXNUM"
27 (:export
28
29 ;; types
30 dfixnum dfparttype
31
32 ;; constructing
33 make-dfixnum
34 dfixnum-make-from-number
35
36 ;; arthmetic with our datatypes
37 dfixnum-inc-df dfixnum-inc-hf
38 dfixnum-set-df dfixnum-dec-df dfixnum-dec-hf
39
40
41 ;; operations with normal datatypes
42 dfixnum-set-from-number dfixnum-inc-integer
43 dfixnum-set-single-float dfixnum-inc-single-float
44 dfixnum-integer dfixnum-single-float
45 dfixnum-single-float dfixnum-single-float-inline
46
47 ;; operations on pairs instead of the dfixnum struct
48 dfixnum-set-pair dfixnum-inc-pair dfixnum-pair-integer
49 dfixnum-dec-pair dfixnum-copy-pair))
50
51 (in-package "DFIXNUM")
52
53 (defconstant dfbits #.(- (integer-length most-positive-fixnum) 1))
54 (defconstant dfmax #.(expt 2 dfbits))
55 (deftype dfparttype () `(integer 0 ,#.(expt 2 dfbits)))
56
57 (defstruct dfixnum
58 (h 0 :type dfparttype)
59 (l 0 :type dfparttype))
60
61 (defun dfixnum-inc-df (v i)
62 "increments dfixnum v by dfixnum i"
63 (declare (type dfixnum v) (type dfixnum i))
64 (let ((low (+ (dfixnum-l v) (dfixnum-l i))))
65 (if (> low dfmax)
66 (progn
67 (setf (dfixnum-l v) (- low dfmax))
68 (incf (dfixnum-h v)))
69 (setf (dfixnum-l v) low)))
70 (let ((high (+ (dfixnum-h v) (dfixnum-h i))))
71 (when (> high dfmax)
72 (error "dfixnum became too big ~a + ~a" v i))
73 (setf (dfixnum-h v) high))
74 v)
75
76 (defun dfixnum-set-df (v i)
77 (declare (type dfixnum v) (type dfixnum i))
78 (setf (dfixnum-h v) (dfixnum-h i))
79 (setf (dfixnum-l v) (dfixnum-l i)))
80
81 (defun dfixnum-inc-hf (v i)
82 "increments dfixnum v by i (max half fixnum)"
83 (declare (type dfixnum v) (type fixnum i))
84 (when (> i dfmax)
85 (error "not a half-fixnum: ~a" i))
86 (let ((low (+ (dfixnum-l v) i)))
87 (if (> low dfmax)
88 (progn
89 (setf (dfixnum-l v) (- low dfmax))
90 (incf (dfixnum-h v)))
91 (setf (dfixnum-l v) (the dfparttype low))))
92 (when (> (+ (dfixnum-h v) i) dfmax)
93 (error "dfixnum became too big ~a + ~a" v i))
94 v)
95
96 (defun dfixnum-dec-df (v i)
97 "decrement dfixnum v by dfixnum i"
98 (declare (type dfixnum v) (type dfixnum i))
99 (let ((low (- (dfixnum-l v) (dfixnum-l i)))
100 (high (- (dfixnum-h v) (dfixnum-h i))))
101 (declare (type fixnum low high))
102 (when (< low 0)
103 (decf high)
104 (setf low (+ low dfmax)))
105 (when (< high 0)
106 (error "dfixnum became negative ~a - ~a (~a/~a)" v i low high))
107 (setf (dfixnum-h v) high)
108 (setf (dfixnum-l v) low))
109 v)
110
111 (defun dfixnum-dec-hf (v i)
112 "decrement dfixnum v by half-fixnum i"
113 (declare (type dfixnum v) (type (integer 0 #.dfmax) i))
114 (let ((low (- (dfixnum-l v) i))
115 (high (dfixnum-h v)))
116 (declare (type fixnum low high))
117 (when (< low 0)
118 (decf high)
119 (setf low (+ low dfmax)))
120 (when (< high 0)
121 (error "dfixnum became negative ~a - ~a (~a/~a)" v i low high))
122 (setf (dfixnum-h v) high)
123 (setf (dfixnum-l v) low))
124 v)
125
126 (defun dfixnum-inc-integer (df i)
127 "increments dfixnum by an interger which may be bigger than fixnum.
128 May cons"
129 (declare (type dfixnum df) (integer i) (optimize (ext:inhibit-warnings 3)))
130 (let ((carry (+ (dfixnum-l df) (mod i dfmax))))
131 (setf (dfixnum-l df) (mod carry dfmax))
132 (if (> carry dfmax)
133 (setf carry 1)
134 (setf carry 0))
135 (setf (dfixnum-h df)
136 (+ (dfixnum-h df)
137 (ash i (- dfbits))
138 carry))))
139
140 (defun dfixnum-set-from-number (df i)
141 (declare (type dfixnum df) (optimize (ext:inhibit-warnings 3)))
142 (setf (dfixnum-h df) (ash i (- dfbits)))
143 (setf (dfixnum-l df) (mod i dfmax)))
144
145 (defun dfixnum-make-from-number (i)
146 "returns a new dfixnum from number i"
147 (declare (type number i) (optimize (ext:inhibit-warnings 3)))
148 (let ((df (make-dfixnum)))
149 (declare (type dfixnum df))
150 (dfixnum-set-from-number df i)
151 df))
152
153 (defun dfixnum-integer (df)
154 (declare (optimize (ext:inhibit-warnings 3)))
155 (+ (* (dfixnum-h df) dfmax)
156 (dfixnum-l df)))
157
158 (defun dfixnum-single-float (df)
159 (declare (optimize (ext:inhibit-warnings 3)))
160 (+ (* (coerce (dfixnum-h df) 'single-float) #.(coerce dfmax 'single-float))
161 (coerce (dfixnum-l df) 'single-float)))
162
163 (defun dfixnum-single-float-inline (df)
164 (declare (optimize (ext:inhibit-warnings 3)))
165 (+ (* (coerce (dfixnum-h df) 'single-float) #.(coerce dfmax 'single-float))
166 (coerce (dfixnum-l df) 'single-float)))
167 (declaim (inline dfixnum-single-float-inline))
168
169 (defmacro dfixnum-set-single-float (float df)
170 `(progn
171 (setf
172 ,float
173 (+ (* (coerce (dfixnum-h ,df) 'single-float)
174 ,#.(coerce dfmax 'single-float))
175 (coerce (dfixnum-l ,df) 'single-float)))))
176
177 (defmacro dfixnum-inc-single-float (float df)
178 `(progn
179 (setf
180 ,float
181 (+ ,float (* (coerce (dfixnum-h ,df) 'single-float)
182 ,#.(coerce dfmax 'single-float))
183 (coerce (dfixnum-l ,df) 'single-float)))))
184
185 (defmacro dfixnum-set-pair (h l dfnum)
186 `(progn
187 (setf ,h (dfixnum-h ,dfnum))
188 (setf ,l (dfixnum-l ,dfnum))))
189
190 (defmacro dfixnum-inc-pair (vh vl ih il)
191 "increments a pair of halffixnums by another pair"
192 `(progn
193 (let ((low (+ ,vl ,il)))
194 (if (> low dfmax)
195 (progn
196 (setf ,vl (- low dfmax))
197 (incf ,vh))
198 (setf ,vl low)))
199 (let ((high (+ ,vh ,ih)))
200 (when (> high dfmax)
201 (error "dfixnum became too big ~a/~a + ~a/~a" ,vh ,vl ,ih ,il))
202 (setf ,vh high))))
203
204 (defun dfixnum-pair-integer (h l)
205 (+ (* h dfmax) l))
206
207 (defmacro dfixnum-dec-pair (vh vl ih il)
208 "decrement dfixnum pair by another pair"
209 `(let ((low (- ,vl ,il))
210 (high (- ,vh ,ih)))
211 (declare (type fixnum low high))
212 (when (< low 0)
213 (decf high)
214 (setf low (+ low dfmax)))
215 (when (< high 0)
216 (error "dfixnum became negative ~a/~a - ~a/~a(~a/~a)"
217 ,vh ,vl ,ih ,il low high))
218 (setf ,vh high)
219 (setf ,vl low)))
220
221 (defmacro dfixnum-copy-pair (vh vl ih il)
222 `(progn
223 (setf ,vh ,ih)
224 (setf ,vl ,il)))

  ViewVC Help
Powered by ViewVC 1.1.5