vm/types.c

   1 #include "master.h"
   2
   3 /* FFI calls this */
   4 void box_boolean(bool value)
   5 {
   6         dpush(value ? T : F);
   7 }
   8
   9 /* FFI calls this */
  10 bool to_boolean(CELL value)
  11 {
  12         return value != F;
  13 }
  14
  15 CELL clone_object(CELL object)
  16 {
  17         CELL size = object_size(object);
  18         if(size == 0)
  19                 return object;
  20         else
  21         {
  22                 REGISTER_ROOT(object);
  23                 void *new_obj = allot_object(type_of(object),size);
  24                 UNREGISTER_ROOT(object);
  25
  26                 CELL tag = TAG(object);
  27                 memcpy(new_obj,(void*)UNTAG(object),size);
  28                 return RETAG(new_obj,tag);
  29         }
  30 }
  31
  32 void primitive_clone(void)
  33 {
  34         drepl(clone_object(dpeek()));
  35 }
  36
  37 F_WORD *allot_word(CELL vocab, CELL name)
  38 {
  39         REGISTER_ROOT(vocab);
  40         REGISTER_ROOT(name);
  41         F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD));
  42         UNREGISTER_ROOT(name);
  43         UNREGISTER_ROOT(vocab);
  44
  45         word->hashcode = tag_fixnum((rand() << 16) ^ rand());
  46         word->vocabulary = vocab;
  47         word->name = name;
  48         word->def = userenv[UNDEFINED_ENV];
  49         word->props = F;
  50         word->counter = tag_fixnum(0);
  51         word->compiledp = F;
  52         word->subprimitive = F;
  53         word->profiling = NULL;
  54         word->code = NULL;
  55
  56         REGISTER_UNTAGGED(word);
  57         default_word_code(word,true);
  58         UNREGISTER_UNTAGGED(word);
  59
  60         REGISTER_UNTAGGED(word);
  61         update_word_xt(word);
  62         UNREGISTER_UNTAGGED(word);
  63
  64         if(profiling_p)
  65                 iterate_code_heap_step(word->profiling,relocate_code_block);
  66
  67         return word;
  68 }
  69
  70 /* <word> ( name vocabulary -- word ) */
  71 void primitive_word(void)
  72 {
  73         CELL vocab = dpop();
  74         CELL name = dpop();
  75         dpush(tag_object(allot_word(vocab,name)));
  76 }
  77
  78 /* word-xt ( word -- start end ) */
  79 void primitive_word_xt(void)
  80 {
  81         F_WORD *word = untag_word(dpop());
  82         F_COMPILED *code = (profiling_p ? word->profiling : word->code);
  83         dpush(allot_cell((CELL)code + sizeof(F_COMPILED)));
  84         dpush(allot_cell((CELL)code + sizeof(F_COMPILED) + code->code_length));
  85 }
  86
  87 void primitive_wrapper(void)
  88 {
  89         F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
  90         wrapper->object = dpeek();
  91         drepl(tag_object(wrapper));
  92 }
  93
  94 /* Arrays */
  95
  96 /* the array is full of undefined data, and must be correctly filled before the
  97 next GC. size is in cells */
  98 F_ARRAY *allot_array_internal(CELL type, CELL capacity)
  99 {
 100         F_ARRAY *array = allot_object(type,array_size(capacity));
 101         array->capacity = tag_fixnum(capacity);
 102         return array;
 103 }
 104
 105 /* make a new array with an initial element */
 106 F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill)
 107 {
 108         int i;
 109         REGISTER_ROOT(fill);
 110         F_ARRAY* array = allot_array_internal(type, capacity);
 111         UNREGISTER_ROOT(fill);
 112         if(fill == 0)
 113                 memset((void*)AREF(array,0),'\0',capacity * CELLS);
 114         else
 115         {
 116                 /* No need for write barrier here. Either the object is in
 117                 the nursery, or it was allocated directly in tenured space
 118                 and the write barrier is already hit for us in that case. */
 119                 for(i = 0; i < capacity; i++)
 120                         put(AREF(array,i),fill);
 121         }
 122         return array;
 123 }
 124
 125 /* push a new array on the stack */
 126 void primitive_array(void)
 127 {
 128         CELL initial = dpop();
 129         CELL size = unbox_array_size();
 130         dpush(tag_object(allot_array(ARRAY_TYPE,size,initial)));
 131 }
 132
 133 CELL allot_array_1(CELL obj)
 134 {
 135         REGISTER_ROOT(obj);
 136         F_ARRAY *a = allot_array_internal(ARRAY_TYPE,1);
 137         UNREGISTER_ROOT(obj);
 138         set_array_nth(a,0,obj);
 139         return tag_object(a);
 140 }
 141
 142 CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4)
 143 {
 144         REGISTER_ROOT(v1);
 145         REGISTER_ROOT(v2);
 146         REGISTER_ROOT(v3);
 147         REGISTER_ROOT(v4);
 148         F_ARRAY *a = allot_array_internal(ARRAY_TYPE,4);
 149         UNREGISTER_ROOT(v4);
 150         UNREGISTER_ROOT(v3);
 151         UNREGISTER_ROOT(v2);
 152         UNREGISTER_ROOT(v1);
 153         set_array_nth(a,0,v1);
 154         set_array_nth(a,1,v2);
 155         set_array_nth(a,2,v3);
 156         set_array_nth(a,3,v4);
 157         return tag_object(a);
 158 }
 159
 160 F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity)
 161 {
 162         CELL to_copy = array_capacity(array);
 163         if(capacity < to_copy)
 164                 to_copy = capacity;
 165
 166         REGISTER_UNTAGGED(array);
 167         F_ARRAY* new_array = allot_array_internal(untag_header(array->header),capacity);
 168         UNREGISTER_UNTAGGED(array);
 169
 170         memcpy(new_array + 1,array + 1,to_copy * CELLS);
 171         memset((char *)AREF(new_array,to_copy),'\0',(capacity - to_copy) * CELLS);
 172
 173         return new_array;
 174 }
 175
 176 void primitive_resize_array(void)
 177 {
 178         F_ARRAY* array = untag_array(dpop());
 179         CELL capacity = unbox_array_size();
 180         dpush(tag_object(reallot_array(array,capacity)));
 181 }
 182
 183 F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count)
 184 {
 185         REGISTER_ROOT(elt);
 186
 187         if(*result_count == array_capacity(result))
 188         {
 189                 result = reallot_array(result,*result_count * 2);
 190         }
 191
 192         UNREGISTER_ROOT(elt);
 193         set_array_nth(result,*result_count,elt);
 194         (*result_count)++;
 195
 196         return result;
 197 }
 198
 199 F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
 200 {
 201         REGISTER_UNTAGGED(elts);
 202
 203         CELL elts_size = array_capacity(elts);
 204         CELL new_size = *result_count + elts_size;
 205
 206         if(new_size >= array_capacity(result))
 207                 result = reallot_array(result,new_size * 2);
 208
 209         UNREGISTER_UNTAGGED(elts);
 210
 211         write_barrier((CELL)result);
 212
 213         memcpy((void *)AREF(result,*result_count),(void *)AREF(elts,0),elts_size * CELLS);
 214
 215         *result_count += elts_size;
 216
 217         return result;
 218 }
 219
 220 /* Byte arrays */
 221
 222 /* must fill out array before next GC */
 223 F_BYTE_ARRAY *allot_byte_array_internal(CELL size)
 224 {
 225         F_BYTE_ARRAY *array = allot_object(BYTE_ARRAY_TYPE,
 226                 byte_array_size(size));
 227         array->capacity = tag_fixnum(size);
 228         return array;
 229 }
 230
 231 /* size is in bytes this time */
 232 F_BYTE_ARRAY *allot_byte_array(CELL size)
 233 {
 234         F_BYTE_ARRAY *array = allot_byte_array_internal(size);
 235         memset(array + 1,0,size);
 236         return array;
 237 }
 238
 239 /* push a new byte array on the stack */
 240 void primitive_byte_array(void)
 241 {
 242         CELL size = unbox_array_size();
 243         dpush(tag_object(allot_byte_array(size)));
 244 }
 245
 246 void primitive_uninitialized_byte_array(void)
 247 {
 248         CELL size = unbox_array_size();
 249         dpush(tag_object(allot_byte_array_internal(size)));
 250 }
 251
 252 F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity)
 253 {
 254         CELL to_copy = array_capacity(array);
 255         if(capacity < to_copy)
 256                 to_copy = capacity;
 257
 258         REGISTER_UNTAGGED(array);
 259         F_BYTE_ARRAY *new_array = allot_byte_array(capacity);
 260         UNREGISTER_UNTAGGED(array);
 261
 262         memcpy(new_array + 1,array + 1,to_copy);
 263
 264         return new_array;
 265 }
 266
 267 void primitive_resize_byte_array(void)
 268 {
 269         F_BYTE_ARRAY* array = untag_byte_array(dpop());
 270         CELL capacity = unbox_array_size();
 271         dpush(tag_object(reallot_byte_array(array,capacity)));
 272 }
 273
 274 F_BYTE_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count)
 275 {
 276         CELL new_size = *result_count + len;
 277
 278         if(new_size >= byte_array_capacity(result))
 279                 result = reallot_byte_array(result,new_size * 2);
 280
 281         memcpy((void *)BREF(result,*result_count),elts,len);
 282
 283         *result_count = new_size;
 284
 285         return result;
 286 }
 287
 288 /* Tuples */
 289
 290 /* push a new tuple on the stack */
 291 F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout)
 292 {
 293         REGISTER_UNTAGGED(layout);
 294         F_TUPLE *tuple = allot_object(TUPLE_TYPE,tuple_size(layout));
 295         UNREGISTER_UNTAGGED(layout);
 296         tuple->layout = tag_object(layout);
 297         return tuple;
 298 }
 299
 300 void primitive_tuple(void)
 301 {
 302         F_TUPLE_LAYOUT *layout = untag_object(dpop());
 303         F_FIXNUM size = untag_fixnum_fast(layout->size);
 304
 305         F_TUPLE *tuple = allot_tuple(layout);
 306         F_FIXNUM i;
 307         for(i = size - 1; i >= 0; i--)
 308                 put(AREF(tuple,i),F);
 309
 310         dpush(tag_tuple(tuple));
 311 }
 312
 313 /* push a new tuple on the stack, filling its slots from the stack */
 314 void primitive_tuple_boa(void)
 315 {
 316         F_TUPLE_LAYOUT *layout = untag_object(dpop());
 317         F_FIXNUM size = untag_fixnum_fast(layout->size);
 318         F_TUPLE *tuple = allot_tuple(layout);
 319         memcpy(tuple + 1,(CELL *)(ds - CELLS * (size - 1)),CELLS * size);
 320         ds -= CELLS * size;
 321         dpush(tag_tuple(tuple));
 322 }
 323
 324 /* Strings */
 325 CELL string_nth(F_STRING* string, CELL index)
 326 {
 327         /* If high bit is set, the most significant 16 bits of the char
 328         come from the aux vector. The least significant bit of the
 329         corresponding aux vector entry is negated, so that we can
 330         XOR the two components together and get the original code point
 331         back. */
 332         CELL ch = bget(SREF(string,index));
 333         if((ch & 0x80) == 0)
 334                 return ch;
 335         else
 336         {
 337                 F_BYTE_ARRAY *aux = untag_object(string->aux);
 338                 return (cget(BREF(aux,index * sizeof(u16))) << 7) ^ ch;
 339         }
 340 }
 341
 342 void set_string_nth_fast(F_STRING* string, CELL index, CELL ch)
 343 {
 344         bput(SREF(string,index),ch);
 345 }
 346
 347 void set_string_nth_slow(F_STRING* string, CELL index, CELL ch)
 348 {
 349         F_BYTE_ARRAY *aux;
 350
 351         bput(SREF(string,index),(ch & 0x7f) | 0x80);
 352
 353         if(string->aux == F)
 354         {
 355                 REGISTER_UNTAGGED(string);
 356                 /* We don't need to pre-initialize the
 357                 byte array with any data, since we
 358                 only ever read from the aux vector
 359                 if the most significant bit of a
 360                 character is set. Initially all of
 361                 the bits are clear. */
 362                 aux = allot_byte_array_internal(
 363                         untag_fixnum_fast(string->length)
 364                         * sizeof(u16));
 365                 UNREGISTER_UNTAGGED(string);
 366
 367                 write_barrier((CELL)string);
 368                 string->aux = tag_object(aux);
 369         }
 370         else
 371                 aux = untag_object(string->aux);
 372
 373         cput(BREF(aux,index * sizeof(u16)),(ch >> 7) ^ 1);
 374 }
 375
 376 /* allocates memory */
 377 void set_string_nth(F_STRING* string, CELL index, CELL ch)
 378 {
 379         if(ch <= 0x7f)
 380                 set_string_nth_fast(string,index,ch);
 381         else
 382                 set_string_nth_slow(string,index,ch);
 383 }
 384
 385 /* untagged */
 386 F_STRING* allot_string_internal(CELL capacity)
 387 {
 388         F_STRING *string = allot_object(STRING_TYPE,string_size(capacity));
 389
 390         string->length = tag_fixnum(capacity);
 391         string->hashcode = F;
 392         string->aux = F;
 393
 394         return string;
 395 }
 396
 397 /* allocates memory */
 398 void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill)
 399 {
 400         if(fill <= 0x7f)
 401                 memset((void *)SREF(string,start),fill,capacity - start);
 402         else
 403         {
 404                 CELL i;
 405
 406                 for(i = start; i < capacity; i++)
 407                 {
 408                         REGISTER_UNTAGGED(string);
 409                         set_string_nth(string,i,fill);
 410                         UNREGISTER_UNTAGGED(string);
 411                 }
 412         }
 413 }
 414
 415 /* untagged */
 416 F_STRING *allot_string(CELL capacity, CELL fill)
 417 {
 418         F_STRING* string = allot_string_internal(capacity);
 419         REGISTER_UNTAGGED(string);
 420         fill_string(string,0,capacity,fill);
 421         UNREGISTER_UNTAGGED(string);
 422         return string;
 423 }
 424
 425 void primitive_string(void)
 426 {
 427         CELL initial = to_cell(dpop());
 428         CELL length = unbox_array_size();
 429         dpush(tag_object(allot_string(length,initial)));
 430 }
 431
 432 F_STRING* reallot_string(F_STRING* string, CELL capacity)
 433 {
 434         CELL to_copy = string_capacity(string);
 435         if(capacity < to_copy)
 436                 to_copy = capacity;
 437
 438         REGISTER_UNTAGGED(string);
 439         F_STRING *new_string = allot_string_internal(capacity);
 440         UNREGISTER_UNTAGGED(string);
 441
 442         memcpy(new_string + 1,string + 1,to_copy);
 443
 444         if(string->aux != F)
 445         {
 446                 REGISTER_UNTAGGED(string);
 447                 REGISTER_UNTAGGED(new_string);
 448                 F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16));
 449                 UNREGISTER_UNTAGGED(new_string);
 450                 UNREGISTER_UNTAGGED(string);
 451
 452                 write_barrier((CELL)new_string);
 453                 new_string->aux = tag_object(new_aux);
 454
 455                 F_BYTE_ARRAY *aux = untag_object(string->aux);
 456                 memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16));
 457         }
 458
 459         REGISTER_UNTAGGED(string);
 460         REGISTER_UNTAGGED(new_string);
 461         fill_string(new_string,to_copy,capacity,'\0');
 462         UNREGISTER_UNTAGGED(new_string);
 463         UNREGISTER_UNTAGGED(string);
 464
 465         return new_string;
 466 }
 467
 468 void primitive_resize_string(void)
 469 {
 470         F_STRING* string = untag_string(dpop());
 471         CELL capacity = unbox_array_size();
 472         dpush(tag_object(reallot_string(string,capacity)));
 473 }
 474
 475 /* Some ugly macros to prevent a 2x code duplication */
 476
 477 #define MEMORY_TO_STRING(type,utype) \
 478         F_STRING *memory_to_##type##_string(const type *string, CELL length) \
 479         { \
 480                 REGISTER_C_STRING(string); \
 481                 F_STRING* s = allot_string_internal(length); \
 482                 UNREGISTER_C_STRING(string); \
 483                 CELL i; \
 484                 for(i = 0; i < length; i++) \
 485                 { \
 486                         REGISTER_UNTAGGED(s); \
 487                         set_string_nth(s,i,(utype)*string); \
 488                         UNREGISTER_UNTAGGED(s); \
 489                         string++; \
 490                 } \
 491                 return s; \
 492         } \
 493         F_STRING *from_##type##_string(const type *str) \
 494         { \
 495                 CELL length = 0; \
 496                 const type *scan = str; \
 497                 while(*scan++) length++; \
 498                 return memory_to_##type##_string(str,length); \
 499         } \
 500         void box_##type##_string(const type *str) \
 501         { \
 502                 dpush(str ? tag_object(from_##type##_string(str)) : F); \
 503         }
 504
 505 MEMORY_TO_STRING(char,u8)
 506 MEMORY_TO_STRING(u16,u16)
 507 MEMORY_TO_STRING(u32,u32)
 508
 509 bool check_string(F_STRING *s, CELL max)
 510 {
 511         CELL capacity = string_capacity(s);
 512         CELL i;
 513         for(i = 0; i < capacity; i++)
 514         {
 515                 CELL ch = string_nth(s,i);
 516                 if(ch == '\0' || ch >= (1 << (max * 8)))
 517                         return false;
 518         }
 519         return true;
 520 }
 521
 522 F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size)
 523 {
 524         return allot_byte_array((capacity + 1) * size);
 525 }
 526
 527 #define STRING_TO_MEMORY(type) \
 528         void type##_string_to_memory(F_STRING *s, type *string) \
 529         { \
 530                 CELL i; \
 531                 CELL capacity = string_capacity(s); \
 532                 for(i = 0; i < capacity; i++) \
 533                         string[i] = string_nth(s,i); \
 534         } \
 535         void primitive_##type##_string_to_memory(void) \
 536         { \
 537                 type *address = unbox_alien(); \
 538                 F_STRING *str = untag_string(dpop()); \
 539                 type##_string_to_memory(str,address); \
 540         } \
 541         F_BYTE_ARRAY *string_to_##type##_alien(F_STRING *s, bool check) \
 542         { \
 543                 CELL capacity = string_capacity(s); \
 544                 F_BYTE_ARRAY *_c_str; \
 545                 if(check && !check_string(s,sizeof(type))) \
 546                         general_error(ERROR_C_STRING,tag_object(s),F,NULL); \
 547                 REGISTER_UNTAGGED(s); \
 548                 _c_str = allot_c_string(capacity,sizeof(type)); \
 549                 UNREGISTER_UNTAGGED(s); \
 550                 type *c_str = (type*)(_c_str + 1); \
 551                 type##_string_to_memory(s,c_str); \
 552                 c_str[capacity] = 0; \
 553                 return _c_str; \
 554         } \
 555         type *to_##type##_string(F_STRING *s, bool check) \
 556         { \
 557                 return (type*)(string_to_##type##_alien(s,check) + 1); \
 558         } \
 559         type *unbox_##type##_string(void) \
 560         { \
 561                 return to_##type##_string(untag_string(dpop()),true); \
 562         }
 563
 564 STRING_TO_MEMORY(char);
 565 STRING_TO_MEMORY(u16);
 566
 567 void primitive_string_nth(void)
 568 {
 569         F_STRING *string = untag_object(dpop());
 570         CELL index = untag_fixnum_fast(dpop());
 571         dpush(tag_fixnum(string_nth(string,index)));
 572 }
 573
 574 void primitive_set_string_nth(void)
 575 {
 576         F_STRING *string = untag_object(dpop());
 577         CELL index = untag_fixnum_fast(dpop());
 578         CELL value = untag_fixnum_fast(dpop());
 579         set_string_nth(string,index,value);
 580 }
 581
 582 void primitive_set_string_nth_fast(void)
 583 {
 584         F_STRING *string = untag_object(dpop());
 585         CELL index = untag_fixnum_fast(dpop());
 586         CELL value = untag_fixnum_fast(dpop());
 587         set_string_nth_fast(string,index,value);
 588 }
 589
 590 void primitive_set_string_nth_slow(void)
 591 {
 592         F_STRING *string = untag_object(dpop());
 593         CELL index = untag_fixnum_fast(dpop());
 594         CELL value = untag_fixnum_fast(dpop());
 595         set_string_nth_slow(string,index,value);
 596 }