| 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. |
| 5 | * |
| 6 | * MLton is released under a BSD-style license. |
| 7 | * See the file MLton-LICENSE for details. |
| 8 | */ |
| 9 | |
| 10 | /* |
| 11 | * Test if a intInf is a fixnum. |
| 12 | */ |
| 13 | static inline bool isSmall (objptr arg) { |
| 14 | return (arg & 1); |
| 15 | } |
| 16 | |
| 17 | static inline bool areSmall (objptr arg1, objptr arg2) { |
| 18 | return ((arg1 & arg2) & (objptr)1); |
| 19 | } |
| 20 | |
| 21 | /* |
| 22 | * Convert a bignum intInf to a bignum pointer. |
| 23 | */ |
| 24 | static inline GC_intInf toBignum (GC_state s, objptr arg) { |
| 25 | GC_intInf bp; |
| 26 | |
| 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))); |
| 31 | if (DEBUG_INT_INF) |
| 32 | fprintf (stderr, "bp->header = "FMTHDR"\n", bp->header); |
| 33 | assert (bp->header == GC_INTINF_HEADER); |
| 34 | return bp; |
| 35 | } |
| 36 | |
| 37 | /* |
| 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 |
| 40 | * __mpz_struct. |
| 41 | */ |
| 42 | void fillIntInfArg (GC_state s, objptr arg, __mpz_struct *res, |
| 43 | mp_limb_t space[LIMBS_PER_OBJPTR + 1]) { |
| 44 | GC_intInf bp; |
| 45 | |
| 46 | if (DEBUG_INT_INF) |
| 47 | fprintf (stderr, "fillIntInfArg ("FMTOBJPTR", "FMTPTR", "FMTPTR")\n", |
| 48 | arg, (uintptr_t)res, (uintptr_t)space); |
| 49 | if (isSmall(arg)) { |
| 50 | res->_mp_alloc = LIMBS_PER_OBJPTR + 1; |
| 51 | res->_mp_d = space; |
| 52 | if (arg == (objptr)1) { |
| 53 | res->_mp_size = 0; |
| 54 | } else { |
| 55 | const objptr highBitMask = (objptr)1 << (CHAR_BIT * OBJPTR_SIZE - 1); |
| 56 | bool neg = (arg & highBitMask) != (objptr)0; |
| 57 | if (neg) { |
| 58 | arg = -((arg >> 1) | highBitMask); |
| 59 | } else { |
| 60 | arg = (arg >> 1); |
| 61 | } |
| 62 | int size; |
| 63 | if (sizeof(objptr) <= sizeof(mp_limb_t)) { |
| 64 | space[0] = (mp_limb_t)arg; |
| 65 | size = 1; |
| 66 | } else { |
| 67 | size = 0; |
| 68 | while (arg != 0) { |
| 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)); |
| 77 | size++; |
| 78 | } |
| 79 | } |
| 80 | if (neg) |
| 81 | size = - size; |
| 82 | res->_mp_size = size; |
| 83 | } |
| 84 | } else { |
| 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. |
| 89 | */ |
| 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; |
| 93 | } |
| 94 | assert ((res->_mp_size == 0) |
| 95 | or (res->_mp_d[(res->_mp_size < 0 |
| 96 | ? - res->_mp_size |
| 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)); |
| 101 | } |
| 102 | |
| 103 | /* |
| 104 | * Initialize an __mpz_struct to use the space provided by the heap. |
| 105 | */ |
| 106 | void initIntInfRes (GC_state s, __mpz_struct *res, |
| 107 | ARG_USED_FOR_ASSERT size_t bytes) { |
| 108 | GC_intInf bp; |
| 109 | size_t nlimbs; |
| 110 | |
| 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. |
| 115 | */ |
| 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 |
| 119 | * heaps. |
| 120 | */ |
| 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? */ |
| 124 | } |
| 125 | |
| 126 | /* |
| 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 |
| 130 | * rolled back. |
| 131 | * If the answer doesn't need all of the space allocated, we adjust |
| 132 | * the array size and roll the frontier slightly back. |
| 133 | */ |
| 134 | objptr finiIntInfRes (GC_state s, __mpz_struct *res, size_t bytes) { |
| 135 | GC_intInf bp; |
| 136 | int size; |
| 137 | |
| 138 | assert ((res->_mp_size == 0) |
| 139 | or (res->_mp_d[(res->_mp_size < 0 |
| 140 | ? - res->_mp_size |
| 141 | : res->_mp_size) - 1] != 0)); |
| 142 | if (DEBUG_INT_INF) |
| 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; |
| 153 | if (size < 0) { |
| 154 | bp->obj.isneg = TRUE; |
| 155 | size = - size; |
| 156 | } else |
| 157 | bp->obj.isneg = FALSE; |
| 158 | assert (size >= 0); |
| 159 | if (size == 0) |
| 160 | return (objptr)1; |
| 161 | if (size <= LIMBS_PER_OBJPTR) { |
| 162 | if (sizeof(objptr) <= sizeof(mp_limb_t)) { |
| 163 | objptr ans; |
| 164 | mp_limb_t val = bp->obj.limbs[0]; |
| 165 | if (bp->obj.isneg) { |
| 166 | /* |
| 167 | * We only fit if val in [1, 2^(CHAR_BIT * OBJPTR_SIZE - 2)]. |
| 168 | */ |
| 169 | ans = (objptr)(- val); |
| 170 | val = val - 1; |
| 171 | } else |
| 172 | /* |
| 173 | * We only fit if val in [0, 2^(CHAR_BIT * OBJPTR_SIZE - 2) - 1]. |
| 174 | */ |
| 175 | ans = (objptr)val; |
| 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)) |
| 183 | return (ans<<1 | 1); |
| 184 | } else { |
| 185 | objptr ans, val; |
| 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]); |
| 196 | } |
| 197 | if (bp->obj.isneg) { |
| 198 | /* |
| 199 | * We only fit if val in [1, 2^(CHAR_BIT * OBJPTR_SIZE - 2)]. |
| 200 | */ |
| 201 | ans = - val; |
| 202 | val = val - 1; |
| 203 | } else |
| 204 | /* |
| 205 | * We only fit if val in [0, 2^(CHAR_BIT * OBJPTR_SIZE - 2) - 1]. |
| 206 | */ |
| 207 | ans = val; |
| 208 | if (val < (objptr)1<<(CHAR_BIT * OBJPTR_SIZE - 2)) |
| 209 | return (ans<<1 | 1); |
| 210 | } |
| 211 | } |
| 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); |
| 217 | } |
| 218 | |
| 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]; |
| 226 | |
| 227 | if (DEBUG_INT_INF) |
| 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); |
| 235 | } |
| 236 | |
| 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]; |
| 243 | |
| 244 | if (DEBUG_INT_INF) |
| 245 | fprintf (stderr, "IntInf_unop ("FMTOBJPTR", %"PRIuMAX")\n", |
| 246 | arg, (uintmax_t)bytes); |
| 247 | |
| 248 | initIntInfRes (s, &resmpz, bytes); |
| 249 | fillIntInfArg (s, arg, &argmpz, argspace); |
| 250 | unop (&resmpz, &argmpz); |
| 251 | return finiIntInfRes (s, &resmpz, bytes); |
| 252 | } |
| 253 | |
| 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)) |
| 259 | { |
| 260 | __mpz_struct argmpz, resmpz; |
| 261 | mp_limb_t argspace[LIMBS_PER_OBJPTR + 1]; |
| 262 | |
| 263 | if (DEBUG_INT_INF) |
| 264 | fprintf (stderr, "IntInf_shop ("FMTOBJPTR", %"PRIu32", %"PRIuMAX")\n", |
| 265 | arg, shift, (uintmax_t)bytes); |
| 266 | |
| 267 | initIntInfRes (s, &resmpz, bytes); |
| 268 | fillIntInfArg (s, arg, &argmpz, argspace); |
| 269 | shop (&resmpz, &argmpz, (unsigned long)shift); |
| 270 | return finiIntInfRes (s, &resmpz, bytes); |
| 271 | } |
| 272 | |
| 273 | Int32_t IntInf_cmpop (GC_state s, objptr lhs, objptr rhs, |
| 274 | int(*cmpop)(const __mpz_struct *lhsspace, |
| 275 | const __mpz_struct *rhsspace)) |
| 276 | { |
| 277 | __mpz_struct lhsmpz, rhsmpz; |
| 278 | mp_limb_t lhsspace[LIMBS_PER_OBJPTR + 1], rhsspace[LIMBS_PER_OBJPTR + 1]; |
| 279 | int res; |
| 280 | |
| 281 | if (DEBUG_INT_INF) |
| 282 | fprintf (stderr, "IntInf_cmpop ("FMTOBJPTR", "FMTOBJPTR")\n", |
| 283 | lhs, rhs); |
| 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; |
| 289 | return 0; |
| 290 | } |
| 291 | |
| 292 | objptr IntInf_strop (GC_state s, objptr arg, Int32_t base, size_t bytes, |
| 293 | char*(*strop)(char *str, |
| 294 | int base, |
| 295 | const __mpz_struct *argspace)) |
| 296 | { |
| 297 | GC_string8 sp; |
| 298 | __mpz_struct argmpz; |
| 299 | mp_limb_t argspace[LIMBS_PER_OBJPTR + 1]; |
| 300 | char *str; |
| 301 | size_t size; |
| 302 | |
| 303 | if (DEBUG_INT_INF) |
| 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); |
| 312 | size = strlen(str); |
| 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); |
| 320 | } |
| 321 | |
| 322 | /* |
| 323 | static GC_state intInfMemoryFuncsState; |
| 324 | |
| 325 | static void * wrap_alloc_func(size_t size) { |
| 326 | if (DEBUG_INT_INF) |
| 327 | fprintf (stderr, "alloc_func (size = %"PRIuMAX") = ", |
| 328 | (uintmax_t)size); |
| 329 | void * res = (*alloc_func_ptr)(size); |
| 330 | if (DEBUG_INT_INF) |
| 331 | fprintf (stderr, FMTPTR"\n", (uintptr_t)res); |
| 332 | return res; |
| 333 | } |
| 334 | |
| 335 | static void * wrap_realloc_func(void *ptr, size_t old_size, size_t new_size) { |
| 336 | if (DEBUG_INT_INF) |
| 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); |
| 342 | if (DEBUG_INT_INF) |
| 343 | fprintf (stderr, FMTPTR"\n", (uintptr_t)res); |
| 344 | return res; |
| 345 | } |
| 346 | |
| 347 | static void wrap_free_func(void *ptr, size_t size) { |
| 348 | if (DEBUG_INT_INF) |
| 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); |
| 353 | if (DEBUG_INT_INF) |
| 354 | fprintf (stderr, "\n"); |
| 355 | return; |
| 356 | } |
| 357 | |
| 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); |
| 362 | return; |
| 363 | } |
| 364 | */ |
| 365 | |
| 366 | void initIntInf (__attribute__ ((unused)) GC_state s) { |
| 367 | return; |
| 368 | } |