1 /* Copyright (C) 2012,2014 Matthew Fluet.
2 * Copyright (C) 1999-2005, 2007-2008 Henry Cejtin, Matthew Fluet,
3 * Suresh Jagannathan, and Stephen Weeks.
4 * Copyright (C) 1997-2000 NEC Research Institute.
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
11 * Test if a intInf is a fixnum.
13 static inline bool isSmall (objptr arg
) {
17 static inline bool areSmall (objptr arg1
, objptr arg2
) {
18 return ((arg1
& arg2
) & (objptr
)1);
22 * Convert a bignum intInf to a bignum pointer.
24 static inline GC_intInf
toBignum (GC_state s
, objptr arg
) {
27 assert (not isSmall(arg
));
28 bp
= (GC_intInf
)(objptrToPointer(arg
, s
->heap
.start
)
29 - (offsetof(struct GC_intInf
, obj
)
30 + offsetof(struct GC_intInf_obj
, isneg
)));
32 fprintf (stderr
, "bp->header = "FMTHDR
"\n", bp
->header
);
33 assert (bp
->header
== GC_INTINF_HEADER
);
38 * Given an intInf, a pointer to an __mpz_struct and space large
39 * enough to contain LIMBS_PER_OBJPTR + 1 limbs, fill in the
42 void fillIntInfArg (GC_state s
, objptr arg
, __mpz_struct
*res
,
43 mp_limb_t space
[LIMBS_PER_OBJPTR
+ 1]) {
47 fprintf (stderr
, "fillIntInfArg ("FMTOBJPTR
", "FMTPTR
", "FMTPTR
")\n",
48 arg
, (uintptr_t)res
, (uintptr_t)space
);
50 res
->_mp_alloc
= LIMBS_PER_OBJPTR
+ 1;
52 if (arg
== (objptr
)1) {
55 const objptr highBitMask
= (objptr
)1 << (CHAR_BIT
* OBJPTR_SIZE
- 1);
56 bool neg
= (arg
& highBitMask
) != (objptr
)0;
58 arg
= -((arg
>> 1) | highBitMask
);
63 if (sizeof(objptr
) <= sizeof(mp_limb_t
)) {
64 space
[0] = (mp_limb_t
)arg
;
69 space
[size
] = (mp_limb_t
)arg
;
70 // The conditional below is to quell a gcc warning:
71 // right shift count >= width of type
72 // When (sizeof(objptr) <= sizeof(mp_limb_t)),
73 // this branch is unreachable,
74 // so the shift doesn't matter.
75 arg
= arg
>> (sizeof(objptr
) <= sizeof(mp_limb_t
) ?
76 0 : CHAR_BIT
* sizeof(mp_limb_t
));
85 bp
= toBignum (s
, arg
);
86 /* The _mp_alloc field is declared as int.
87 * No possibility of an overflowing assignment, as all *huge*
88 * intInfs must have come from some previous GnuMP evaluation.
90 res
->_mp_alloc
= (int)(bp
->length
- 1);
91 res
->_mp_d
= (mp_limb_t
*)(bp
->obj
.limbs
);
92 res
->_mp_size
= bp
->obj
.isneg
? - res
->_mp_alloc
: res
->_mp_alloc
;
94 assert ((res
->_mp_size
== 0)
95 or (res
->_mp_d
[(res
->_mp_size
< 0
97 : res
->_mp_size
) - 1] != 0));
98 if (DEBUG_INT_INF_DETAILED
)
99 fprintf (stderr
, "arg --> %s\n",
100 mpz_get_str (NULL
, 10, res
));
104 * Initialize an __mpz_struct to use the space provided by the heap.
106 void initIntInfRes (GC_state s
, __mpz_struct
*res
,
107 ARG_USED_FOR_ASSERT
size_t bytes
) {
111 assert (bytes
<= (size_t)(s
->limitPlusSlop
- s
->frontier
));
112 bp
= (GC_intInf
)s
->frontier
;
113 /* We have as much space for the limbs as there is to the end of the
114 * heap. Divide by (sizeof(mp_limb_t)) to get number of limbs.
116 nlimbs
= ((size_t)(s
->limitPlusSlop
- (pointer
)bp
->obj
.limbs
)) / (sizeof(mp_limb_t
));
117 /* The _mp_alloc field is declared as int.
118 * Avoid an overflowing assignment, which could happen with huge
121 res
->_mp_alloc
= (int)(min(nlimbs
,(size_t)INT_MAX
));
122 res
->_mp_d
= (mp_limb_t
*)(bp
->obj
.limbs
);
123 res
->_mp_size
= 0; /* is this necessary? */
127 * Given an __mpz_struct pointer which reflects the answer, set
128 * gcState.frontier and return the answer.
129 * If the answer fits in a fixnum, we return that, with the frontier
131 * If the answer doesn't need all of the space allocated, we adjust
132 * the array size and roll the frontier slightly back.
134 objptr
finiIntInfRes (GC_state s
, __mpz_struct
*res
, size_t bytes
) {
138 assert ((res
->_mp_size
== 0)
139 or (res
->_mp_d
[(res
->_mp_size
< 0
141 : res
->_mp_size
) - 1] != 0));
143 fprintf (stderr
, "finiIntInfRes ("FMTPTR
", %"PRIuMAX
")\n",
144 (uintptr_t)res
, (uintmax_t)bytes
);
145 if (DEBUG_INT_INF_DETAILED
)
146 fprintf (stderr
, "res --> %s\n",
147 mpz_get_str (NULL
, 10, res
));
148 bp
= (GC_intInf
)((pointer
)res
->_mp_d
149 - (offsetof(struct GC_intInf
, obj
)
150 + offsetof(struct GC_intInf_obj
, limbs
)));
151 assert (res
->_mp_d
== (mp_limb_t
*)(bp
->obj
.limbs
));
152 size
= res
->_mp_size
;
154 bp
->obj
.isneg
= TRUE
;
157 bp
->obj
.isneg
= FALSE
;
161 if (size
<= LIMBS_PER_OBJPTR
) {
162 if (sizeof(objptr
) <= sizeof(mp_limb_t
)) {
164 mp_limb_t val
= bp
->obj
.limbs
[0];
167 * We only fit if val in [1, 2^(CHAR_BIT * OBJPTR_SIZE - 2)].
169 ans
= (objptr
)(- val
);
173 * We only fit if val in [0, 2^(CHAR_BIT * OBJPTR_SIZE - 2) - 1].
176 // The conditional below is to quell a gcc warning:
177 // right shift count >= width of type
178 // When (sizeof(objptr) > sizeof(mp_limb_t)),
179 // this branch is unreachable,
180 // so the shift doesn't matter.
181 if (val
< (mp_limb_t
)1<<(sizeof(objptr
) > sizeof(mp_limb_t
) ?
182 0 : CHAR_BIT
* OBJPTR_SIZE
- 2))
186 val
= (objptr
)(bp
->obj
.limbs
[0]);
187 for (int i
= 1; i
< size
; i
++) {
188 // The conditional below is to quell a gcc warning:
189 // left shift count >= width of type
190 // When (sizeof(objptr) <= sizeof(mp_limb_t)),
191 // this branch is unreachable,
192 // so the shift doesn't matter.
193 val
= val
<< (sizeof(objptr
) <= sizeof(mp_limb_t
) ?
194 0 : CHAR_BIT
* sizeof(mp_limb_t
));
195 val
= val
& (objptr
)(bp
->obj
.limbs
[i
]);
199 * We only fit if val in [1, 2^(CHAR_BIT * OBJPTR_SIZE - 2)].
205 * We only fit if val in [0, 2^(CHAR_BIT * OBJPTR_SIZE - 2) - 1].
208 if (val
< (objptr
)1<<(CHAR_BIT
* OBJPTR_SIZE
- 2))
212 setFrontier (s
, (pointer
)(&bp
->obj
.limbs
[size
]), bytes
);
213 bp
->counter
= (GC_arrayCounter
)0;
214 bp
->length
= (GC_arrayLength
)(size
+ 1); /* +1 for isneg field */
215 bp
->header
= GC_INTINF_HEADER
;
216 return pointerToObjptr ((pointer
)&bp
->obj
, s
->heap
.start
);
219 objptr
IntInf_binop (GC_state s
,
220 objptr lhs
, objptr rhs
, size_t bytes
,
221 void(*binop
)(__mpz_struct
*resmpz
,
222 const __mpz_struct
*lhsspace
,
223 const __mpz_struct
*rhsspace
)) {
224 __mpz_struct lhsmpz
, rhsmpz
, resmpz
;
225 mp_limb_t lhsspace
[LIMBS_PER_OBJPTR
+ 1], rhsspace
[LIMBS_PER_OBJPTR
+ 1];
228 fprintf (stderr
, "IntInf_binop ("FMTOBJPTR
", "FMTOBJPTR
", %"PRIuMAX
")\n",
229 lhs
, rhs
, (uintmax_t)bytes
);
230 initIntInfRes (s
, &resmpz
, bytes
);
231 fillIntInfArg (s
, lhs
, &lhsmpz
, lhsspace
);
232 fillIntInfArg (s
, rhs
, &rhsmpz
, rhsspace
);
233 binop (&resmpz
, &lhsmpz
, &rhsmpz
);
234 return finiIntInfRes (s
, &resmpz
, bytes
);
237 objptr
IntInf_unop (GC_state s
,
238 objptr arg
, size_t bytes
,
239 void(*unop
)(__mpz_struct
*resmpz
,
240 const __mpz_struct
*argspace
)) {
241 __mpz_struct argmpz
, resmpz
;
242 mp_limb_t argspace
[LIMBS_PER_OBJPTR
+ 1];
245 fprintf (stderr
, "IntInf_unop ("FMTOBJPTR
", %"PRIuMAX
")\n",
246 arg
, (uintmax_t)bytes
);
248 initIntInfRes (s
, &resmpz
, bytes
);
249 fillIntInfArg (s
, arg
, &argmpz
, argspace
);
250 unop (&resmpz
, &argmpz
);
251 return finiIntInfRes (s
, &resmpz
, bytes
);
254 objptr
IntInf_shop (GC_state s
,
255 objptr arg
, Word32_t shift
, size_t bytes
,
256 void(*shop
)(__mpz_struct
*resmpz
,
257 const __mpz_struct
*argspace
,
258 unsigned long shift
))
260 __mpz_struct argmpz
, resmpz
;
261 mp_limb_t argspace
[LIMBS_PER_OBJPTR
+ 1];
264 fprintf (stderr
, "IntInf_shop ("FMTOBJPTR
", %"PRIu32
", %"PRIuMAX
")\n",
265 arg
, shift
, (uintmax_t)bytes
);
267 initIntInfRes (s
, &resmpz
, bytes
);
268 fillIntInfArg (s
, arg
, &argmpz
, argspace
);
269 shop (&resmpz
, &argmpz
, (unsigned long)shift
);
270 return finiIntInfRes (s
, &resmpz
, bytes
);
273 Int32_t
IntInf_cmpop (GC_state s
, objptr lhs
, objptr rhs
,
274 int(*cmpop
)(const __mpz_struct
*lhsspace
,
275 const __mpz_struct
*rhsspace
))
277 __mpz_struct lhsmpz
, rhsmpz
;
278 mp_limb_t lhsspace
[LIMBS_PER_OBJPTR
+ 1], rhsspace
[LIMBS_PER_OBJPTR
+ 1];
282 fprintf (stderr
, "IntInf_cmpop ("FMTOBJPTR
", "FMTOBJPTR
")\n",
284 fillIntInfArg (s
, lhs
, &lhsmpz
, lhsspace
);
285 fillIntInfArg (s
, rhs
, &rhsmpz
, rhsspace
);
286 res
= cmpop (&lhsmpz
, &rhsmpz
);
287 if (res
< 0) return -1;
288 if (res
> 0) return 1;
292 objptr
IntInf_strop (GC_state s
, objptr arg
, Int32_t base
, size_t bytes
,
293 char*(*strop
)(char *str
,
295 const __mpz_struct
*argspace
))
299 mp_limb_t argspace
[LIMBS_PER_OBJPTR
+ 1];
304 fprintf (stderr
, "IntInf_strop ("FMTOBJPTR
", %"PRId32
", %"PRIuMAX
")\n",
305 arg
, base
, (uintmax_t)bytes
);
306 assert (base
== 2 || base
== 8 || base
== 10 || base
== 16);
307 fillIntInfArg (s
, arg
, &argmpz
, argspace
);
308 assert (bytes
<= (size_t)(s
->limitPlusSlop
- s
->frontier
));
309 sp
= (GC_string8
)s
->frontier
;
310 str
= strop ((void*)&sp
->obj
, -base
, &argmpz
);
311 assert (str
== (char*)&sp
->obj
);
313 if (sp
->obj
.chars
[0] == '-')
314 sp
->obj
.chars
[0] = '~';
315 setFrontier (s
, (pointer
)&sp
->obj
+ size
, bytes
);
316 sp
->counter
= (GC_arrayCounter
)0;
317 sp
->length
= (GC_arrayLength
)size
;
318 sp
->header
= GC_STRING8_HEADER
;
319 return pointerToObjptr ((pointer
)&sp
->obj
, s
->heap
.start
);
323 static GC_state intInfMemoryFuncsState;
325 static void * wrap_alloc_func(size_t size) {
327 fprintf (stderr, "alloc_func (size = %"PRIuMAX") = ",
329 void * res = (*alloc_func_ptr)(size);
331 fprintf (stderr, FMTPTR"\n", (uintptr_t)res);
335 static void * wrap_realloc_func(void *ptr, size_t old_size, size_t new_size) {
337 fprintf (stderr, "realloc_func (ptr = "FMTPTR", "
338 "old_size = %"PRIuMAX", new_size = %"PRIuMAX") = ",
339 (uintptr_t)ptr, (uintmax_t)old_size, (uintmax_t)new_size);
340 assert (! isPointerInHeap(intInfMemoryFuncsState, (pointer)ptr));
341 void * res = (*realloc_func_ptr)(ptr, old_size, new_size);
343 fprintf (stderr, FMTPTR"\n", (uintptr_t)res);
347 static void wrap_free_func(void *ptr, size_t size) {
349 fprintf (stderr, "free_func (ptr = "FMTPTR", size = %"PRIuMAX")",
350 (uintptr_t)ptr, (uintmax_t)size);
351 assert (! isPointerInHeap(intInfMemoryFuncsState, (pointer)ptr));
352 (*free_func_ptr)(ptr, size);
354 fprintf (stderr, "\n");
358 void initIntInf (GC_state s) {
359 intInfMemoryFuncsState = s;
360 mp_get_memory_functions (&alloc_func_ptr, &realloc_func_ptr, &free_func_ptr);
361 mp_set_memory_functions (&wrap_alloc_func, &wrap_realloc_func, &wrap_free_func);
366 void initIntInf (__attribute__ ((unused
)) GC_state s
) {