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

Contents of /src/code/dfixnum.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (hide 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 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 rtoy 1.6 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/dfixnum.lisp,v 1.6 2010/04/20 17:57:44 rtoy 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 rtoy 1.4 (intl:textdomain "cmucl")
27    
28 cracauer 1.1 (defpackage "DFIXNUM"
29 cracauer 1.3 (: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 cracauer 1.1
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 rtoy 1.5 "increments dfixnum v by dfixnum i"
65 cracauer 1.1 (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 rtoy 1.6 (error (intl:gettext "dfixnum became too big ~a + ~a") v i))
75 cracauer 1.1 (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 rtoy 1.5 "increments dfixnum v by i (max half fixnum)"
85 cracauer 1.1 (declare (type dfixnum v) (type fixnum i))
86     (when (> i dfmax)
87 rtoy 1.6 (error (intl:gettext "not a half-fixnum: ~a") i))
88 cracauer 1.1 (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 rtoy 1.6 (error (intl:gettext "dfixnum became too big ~a + ~a") v i))
96 cracauer 1.1 v)
97    
98     (defun dfixnum-dec-df (v i)
99 rtoy 1.5 "decrement dfixnum v by dfixnum i"
100 cracauer 1.1 (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 rtoy 1.6 (error (intl:gettext "dfixnum became negative ~a - ~a (~a/~a)") v i low high))
109 cracauer 1.1 (setf (dfixnum-h v) high)
110     (setf (dfixnum-l v) low))
111     v)
112    
113     (defun dfixnum-dec-hf (v i)
114 rtoy 1.5 "decrement dfixnum v by half-fixnum i"
115 cracauer 1.1 (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 rtoy 1.6 (error (intl:gettext "dfixnum became negative ~a - ~a (~a/~a)") v i low high))
124 cracauer 1.1 (setf (dfixnum-h v) high)
125     (setf (dfixnum-l v) low))
126     v)
127 cracauer 1.3
128     (defun dfixnum-inc-integer (df i)
129 rtoy 1.5 "increments dfixnum by an interger which may be bigger than fixnum.
130 cracauer 1.3 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 cracauer 1.1
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 rtoy 1.5 "returns a new dfixnum from number i"
149 cracauer 1.1 (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 rtoy 1.5 "increments a pair of halffixnums by another pair"
194 cracauer 1.1 `(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 rtoy 1.6 (error (intl:gettext "dfixnum became too big ~a/~a + ~a/~a") ,vh ,vl ,ih ,il))
204 cracauer 1.1 (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 rtoy 1.5 "decrement dfixnum pair by another pair"
211 cracauer 1.1 `(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 rtoy 1.6 (error (intl:gettext "dfixnum became negative ~a/~a - ~a/~a(~a/~a)")
219 cracauer 1.1 ,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