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

Contents of /src/code/dfixnum.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide 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 cracauer 1.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 cracauer 1.3 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/dfixnum.lisp,v 1.3 2003/02/12 18:35:29 cracauer Rel $")
9 cracauer 1.1 ;;;
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 cracauer 1.3 (: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 cracauer 1.1
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 cracauer 1.3
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 cracauer 1.1
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 toy 1.2 (error "dfixnum became negative ~a/~a - ~a/~a(~a/~a)"
217 cracauer 1.1 ,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