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

Contents of /src/code/dfixnum.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Tue Apr 20 17:57:44 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.5: +8 -8 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
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.6 2010/04/20 17:57:44 rtoy 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 (intl:textdomain "cmucl")
27
28 (defpackage "DFIXNUM"
29 (:export
30
31 ;; types
32 dfixnum dfparttype
33
34 ;; constructing
35 make-dfixnum
36 dfixnum-make-from-number
37
38 ;; arthmetic with our datatypes
39 dfixnum-inc-df dfixnum-inc-hf
40 dfixnum-set-df dfixnum-dec-df dfixnum-dec-hf
41
42
43 ;; operations with normal datatypes
44 dfixnum-set-from-number dfixnum-inc-integer
45 dfixnum-set-single-float dfixnum-inc-single-float
46 dfixnum-integer dfixnum-single-float
47 dfixnum-single-float dfixnum-single-float-inline
48
49 ;; operations on pairs instead of the dfixnum struct
50 dfixnum-set-pair dfixnum-inc-pair dfixnum-pair-integer
51 dfixnum-dec-pair dfixnum-copy-pair))
52
53 (in-package "DFIXNUM")
54
55 (defconstant dfbits #.(- (integer-length most-positive-fixnum) 1))
56 (defconstant dfmax #.(expt 2 dfbits))
57 (deftype dfparttype () `(integer 0 ,#.(expt 2 dfbits)))
58
59 (defstruct dfixnum
60 (h 0 :type dfparttype)
61 (l 0 :type dfparttype))
62
63 (defun dfixnum-inc-df (v i)
64 "increments dfixnum v by dfixnum i"
65 (declare (type dfixnum v) (type dfixnum i))
66 (let ((low (+ (dfixnum-l v) (dfixnum-l i))))
67 (if (> low dfmax)
68 (progn
69 (setf (dfixnum-l v) (- low dfmax))
70 (incf (dfixnum-h v)))
71 (setf (dfixnum-l v) low)))
72 (let ((high (+ (dfixnum-h v) (dfixnum-h i))))
73 (when (> high dfmax)
74 (error (intl:gettext "dfixnum became too big ~a + ~a") v i))
75 (setf (dfixnum-h v) high))
76 v)
77
78 (defun dfixnum-set-df (v i)
79 (declare (type dfixnum v) (type dfixnum i))
80 (setf (dfixnum-h v) (dfixnum-h i))
81 (setf (dfixnum-l v) (dfixnum-l i)))
82
83 (defun dfixnum-inc-hf (v i)
84 "increments dfixnum v by i (max half fixnum)"
85 (declare (type dfixnum v) (type fixnum i))
86 (when (> i dfmax)
87 (error (intl:gettext "not a half-fixnum: ~a") i))
88 (let ((low (+ (dfixnum-l v) i)))
89 (if (> low dfmax)
90 (progn
91 (setf (dfixnum-l v) (- low dfmax))
92 (incf (dfixnum-h v)))
93 (setf (dfixnum-l v) (the dfparttype low))))
94 (when (> (+ (dfixnum-h v) i) dfmax)
95 (error (intl:gettext "dfixnum became too big ~a + ~a") v i))
96 v)
97
98 (defun dfixnum-dec-df (v i)
99 "decrement dfixnum v by dfixnum i"
100 (declare (type dfixnum v) (type dfixnum i))
101 (let ((low (- (dfixnum-l v) (dfixnum-l i)))
102 (high (- (dfixnum-h v) (dfixnum-h i))))
103 (declare (type fixnum low high))
104 (when (< low 0)
105 (decf high)
106 (setf low (+ low dfmax)))
107 (when (< high 0)
108 (error (intl:gettext "dfixnum became negative ~a - ~a (~a/~a)") v i low high))
109 (setf (dfixnum-h v) high)
110 (setf (dfixnum-l v) low))
111 v)
112
113 (defun dfixnum-dec-hf (v i)
114 "decrement dfixnum v by half-fixnum i"
115 (declare (type dfixnum v) (type (integer 0 #.dfmax) i))
116 (let ((low (- (dfixnum-l v) i))
117 (high (dfixnum-h v)))
118 (declare (type fixnum low high))
119 (when (< low 0)
120 (decf high)
121 (setf low (+ low dfmax)))
122 (when (< high 0)
123 (error (intl:gettext "dfixnum became negative ~a - ~a (~a/~a)") v i low high))
124 (setf (dfixnum-h v) high)
125 (setf (dfixnum-l v) low))
126 v)
127
128 (defun dfixnum-inc-integer (df i)
129 "increments dfixnum by an interger which may be bigger than fixnum.
130 May cons"
131 (declare (type dfixnum df) (integer i) (optimize (ext:inhibit-warnings 3)))
132 (let ((carry (+ (dfixnum-l df) (mod i dfmax))))
133 (setf (dfixnum-l df) (mod carry dfmax))
134 (if (> carry dfmax)
135 (setf carry 1)
136 (setf carry 0))
137 (setf (dfixnum-h df)
138 (+ (dfixnum-h df)
139 (ash i (- dfbits))
140 carry))))
141
142 (defun dfixnum-set-from-number (df i)
143 (declare (type dfixnum df) (optimize (ext:inhibit-warnings 3)))
144 (setf (dfixnum-h df) (ash i (- dfbits)))
145 (setf (dfixnum-l df) (mod i dfmax)))
146
147 (defun dfixnum-make-from-number (i)
148 "returns a new dfixnum from number i"
149 (declare (type number i) (optimize (ext:inhibit-warnings 3)))
150 (let ((df (make-dfixnum)))
151 (declare (type dfixnum df))
152 (dfixnum-set-from-number df i)
153 df))
154
155 (defun dfixnum-integer (df)
156 (declare (optimize (ext:inhibit-warnings 3)))
157 (+ (* (dfixnum-h df) dfmax)
158 (dfixnum-l df)))
159
160 (defun dfixnum-single-float (df)
161 (declare (optimize (ext:inhibit-warnings 3)))
162 (+ (* (coerce (dfixnum-h df) 'single-float) #.(coerce dfmax 'single-float))
163 (coerce (dfixnum-l df) 'single-float)))
164
165 (defun dfixnum-single-float-inline (df)
166 (declare (optimize (ext:inhibit-warnings 3)))
167 (+ (* (coerce (dfixnum-h df) 'single-float) #.(coerce dfmax 'single-float))
168 (coerce (dfixnum-l df) 'single-float)))
169 (declaim (inline dfixnum-single-float-inline))
170
171 (defmacro dfixnum-set-single-float (float df)
172 `(progn
173 (setf
174 ,float
175 (+ (* (coerce (dfixnum-h ,df) 'single-float)
176 ,#.(coerce dfmax 'single-float))
177 (coerce (dfixnum-l ,df) 'single-float)))))
178
179 (defmacro dfixnum-inc-single-float (float df)
180 `(progn
181 (setf
182 ,float
183 (+ ,float (* (coerce (dfixnum-h ,df) 'single-float)
184 ,#.(coerce dfmax 'single-float))
185 (coerce (dfixnum-l ,df) 'single-float)))))
186
187 (defmacro dfixnum-set-pair (h l dfnum)
188 `(progn
189 (setf ,h (dfixnum-h ,dfnum))
190 (setf ,l (dfixnum-l ,dfnum))))
191
192 (defmacro dfixnum-inc-pair (vh vl ih il)
193 "increments a pair of halffixnums by another pair"
194 `(progn
195 (let ((low (+ ,vl ,il)))
196 (if (> low dfmax)
197 (progn
198 (setf ,vl (- low dfmax))
199 (incf ,vh))
200 (setf ,vl low)))
201 (let ((high (+ ,vh ,ih)))
202 (when (> high dfmax)
203 (error (intl:gettext "dfixnum became too big ~a/~a + ~a/~a") ,vh ,vl ,ih ,il))
204 (setf ,vh high))))
205
206 (defun dfixnum-pair-integer (h l)
207 (+ (* h dfmax) l))
208
209 (defmacro dfixnum-dec-pair (vh vl ih il)
210 "decrement dfixnum pair by another pair"
211 `(let ((low (- ,vl ,il))
212 (high (- ,vh ,ih)))
213 (declare (type fixnum low high))
214 (when (< low 0)
215 (decf high)
216 (setf low (+ low dfmax)))
217 (when (< high 0)
218 (error (intl:gettext "dfixnum became negative ~a/~a - ~a/~a(~a/~a)")
219 ,vh ,vl ,ih ,il low high))
220 (setf ,vh high)
221 (setf ,vl low)))
222
223 (defmacro dfixnum-copy-pair (vh vl ih il)
224 `(progn
225 (setf ,vh ,ih)
226 (setf ,vl ,il)))

  ViewVC Help
Powered by ViewVC 1.1.5