byterun/obj.c

   1 /***********************************************************************/
   2 /*                                                                     */
   3 /*                           Objective Caml                            */
   4 /*                                                                     */
   5 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
   6 /*                                                                     */
   7 /*  Copyright 1996 Institut National de Recherche en Informatique et   */
   8 /*  en Automatique.  All rights reserved.  This file is distributed    */
   9 /*  under the terms of the GNU Library General Public License, with    */
  10 /*  the special exception on linking described in file ../LICENSE.     */
  11 /*                                                                     */
  12 /***********************************************************************/
  13
  14 /* $Id$ */
  15
  16 /* Operations on objects */
  17
  18 #include <string.h>
  19 #include "alloc.h"
  20 #include "fail.h"
  21 #include "gc.h"
  22 #include "interp.h"
  23 #include "major_gc.h"
  24 #include "memory.h"
  25 #include "minor_gc.h"
  26 #include "misc.h"
  27 #include "mlvalues.h"
  28 #include "prims.h"
  29
  30 CAMLprim value caml_static_alloc(value size)
  31 {
  32   return (value) caml_stat_alloc((asize_t) Long_val(size));
  33 }
  34
  35 CAMLprim value caml_static_free(value blk)
  36 {
  37   caml_stat_free((void *) blk);
  38   return Val_unit;
  39 }
  40
  41 /* signal to the interpreter machinery that a bytecode is no more
  42    needed (before freeing it) - this might be useful for a JIT
  43    implementation */
  44
  45 CAMLprim value caml_static_release_bytecode(value blk, value size)
  46 {
  47 #ifndef NATIVE_CODE
  48   caml_release_bytecode((code_t) blk, (asize_t) Long_val(size));
  49 #else
  50   caml_failwith("Meta.static_release_bytecode impossible with native code");
  51 #endif
  52   return Val_unit;
  53 }
  54
  55
  56 CAMLprim value caml_static_resize(value blk, value new_size)
  57 {
  58   return (value) caml_stat_resize((char *) blk, (asize_t) Long_val(new_size));
  59 }
  60
  61 CAMLprim value caml_obj_is_block(value arg)
  62 {
  63   return Val_bool(Is_block(arg));
  64 }
  65
  66 CAMLprim value caml_obj_tag(value arg)
  67 {
  68   if (Is_long (arg)){
  69     return Val_int (1000);
  70   }else if (Is_young (arg) || Is_in_heap (arg) || Is_atom (arg)){
  71     return Val_int(Tag_val(arg));
  72   }else{
  73     return Val_int (1001);
  74   }
  75 }
  76
  77 CAMLprim value caml_obj_set_tag (value arg, value new_tag)
  78 {
  79   Tag_val (arg) = Int_val (new_tag);
  80   return Val_unit;
  81 }
  82
  83 CAMLprim value caml_obj_block(value tag, value size)
  84 {
  85   value res;
  86   mlsize_t sz, i;
  87   tag_t tg;
  88
  89   sz = Long_val(size);
  90   tg = Long_val(tag);
  91   if (sz == 0) return Atom(tg);
  92   res = caml_alloc(sz, tg);
  93   for (i = 0; i < sz; i++)
  94     Field(res, i) = Val_long(0);
  95
  96   return res;
  97 }
  98
  99 CAMLprim value caml_obj_dup(value arg)
 100 {
 101   CAMLparam1 (arg);
 102   CAMLlocal1 (res);
 103   mlsize_t sz, i;
 104   tag_t tg;
 105
 106   sz = Wosize_val(arg);
 107   if (sz == 0) CAMLreturn (arg);
 108   tg = Tag_val(arg);
 109   if (tg >= No_scan_tag) {
 110     res = caml_alloc(sz, tg);
 111     memcpy(Bp_val(res), Bp_val(arg), sz * sizeof(value));
 112   } else if (sz <= Max_young_wosize) {
 113     res = caml_alloc_small(sz, tg);
 114     for (i = 0; i < sz; i++) Field(res, i) = Field(arg, i);
 115   } else {
 116     res = caml_alloc_shr(sz, tg);
 117     for (i = 0; i < sz; i++) caml_initialize(&Field(res, i), Field(arg, i));
 118   }
 119   CAMLreturn (res);
 120 }
 121
 122 /* Shorten the given block to the given size and return void.
 123    Raise Invalid_argument if the given size is less than or equal
 124    to 0 or greater than the current size.
 125
 126    algorithm:
 127    Change the length field of the header.  Make up a white object
 128    with the leftover part of the object: this is needed in the major
 129    heap and harmless in the minor heap.
 130 */
 131 CAMLprim value caml_obj_truncate (value v, value newsize)
 132 {
 133   mlsize_t new_wosize = Long_val (newsize);
 134   header_t hd = Hd_val (v);
 135   tag_t tag = Tag_hd (hd);
 136   color_t color = Color_hd (hd);
 137   mlsize_t wosize = Wosize_hd (hd);
 138   mlsize_t i;
 139
 140   if (tag == Double_array_tag) new_wosize *= Double_wosize;  /* PR#156 */
 141
 142   if (new_wosize <= 0 || new_wosize > wosize){
 143     caml_invalid_argument ("Obj.truncate");
 144   }
 145   if (new_wosize == wosize) return Val_unit;
 146   /* PR#61: since we're about to lose our references to the elements
 147      beyond new_wosize in v, erase them explicitly so that the GC
 148      can darken them as appropriate. */
 149   if (tag < No_scan_tag) {
 150     for (i = new_wosize; i < wosize; i++){
 151       caml_modify(&Field(v, i), Val_unit);
 152 #ifdef DEBUG
 153       Field (v, i) = Debug_free_truncate;
 154 #endif
 155     }
 156   }
 157   /* We must use an odd tag for the header of the leftovers so it does not
 158      look like a pointer because there may be some references to it in
 159      ref_table. */
 160   Field (v, new_wosize) =
 161     Make_header (Wosize_whsize (wosize-new_wosize), 1, Caml_white);
 162   Hd_val (v) = Make_header (new_wosize, tag, color);
 163   return Val_unit;
 164 }
 165
 166
 167 /* The following functions are used in stdlib/lazy.ml.
 168    They are not written in O'Caml because they must be atomic with respect
 169    to the GC.
 170  */
 171
 172 CAMLprim value caml_lazy_follow_forward (value v)
 173 {
 174   if (Is_block (v) && (Is_young (v) || Is_in_heap (v))
 175       && Tag_val (v) == Forward_tag){
 176     return Forward_val (v);
 177   }else{
 178     return v;
 179   }
 180 }
 181
 182 CAMLprim value caml_lazy_make_forward (value v)
 183 {
 184   CAMLparam1 (v);
 185   CAMLlocal1 (res);
 186
 187   res = caml_alloc_small (1, Forward_tag);
 188   Modify (&Field (res, 0), v);
 189   CAMLreturn (res);
 190 }
 191
 192 /* For camlinternalOO.ml
 193    See also GETPUBMET in interp.c
 194  */
 195
 196 CAMLprim value caml_get_public_method (value obj, value tag)
 197 {
 198   value meths = Field (obj, 0);
 199   int li = 3, hi = Field(meths,0), mi;
 200   while (li < hi) {
 201     mi = ((li+hi) >> 1) | 1;
 202     if (tag < Field(meths,mi)) hi = mi-2;
 203     else li = mi;
 204   }
 205   return Field (meths, li-1);
 206 }
 207
 208 /* these two functions might be useful to an hypothetical JIT */
 209
 210 #ifdef CAML_JIT
 211 #ifdef NATIVE_CODE
 212 #define MARK 1
 213 #else
 214 #define MARK 0
 215 #endif
 216 value caml_cache_public_method (value meths, value tag, value *cache)
 217 {
 218   int li = 3, hi = Field(meths,0), mi;
 219   while (li < hi) {
 220     mi = ((li+hi) >> 1) | 1;
 221     if (tag < Field(meths,mi)) hi = mi-2;
 222     else li = mi;
 223   }
 224   *cache = (li-3)*sizeof(value) + MARK;
 225   return Field (meths, li-1);
 226 }
 227
 228 value caml_cache_public_method2 (value *meths, value tag, value *cache)
 229 {
 230   value ofs = *cache & meths[1];
 231   if (*(value*)(((char*)(meths+3)) + ofs - MARK) == tag)
 232     return *(value*)(((char*)(meths+2)) + ofs - MARK);
 233   {
 234     int li = 3, hi = meths[0], mi;
 235     while (li < hi) {
 236       mi = ((li+hi) >> 1) | 1;
 237       if (tag < meths[mi]) hi = mi-2;
 238       else li = mi;
 239     }
 240     *cache = (li-3)*sizeof(value) + MARK;
 241     return meths[li-1];
 242   }
 243 }
 244 #endif /*CAML_JIT*/