vm/alien.cpp

   1 #include "master.hpp"
   2
   3 namespace factor
   4 {
   5
   6 /* gets the address of an object representing a C pointer, with the
   7 intention of storing the pointer across code which may potentially GC. */
   8 char *factor_vm::pinned_alien_offset(cell obj)
   9 {
  10         switch(tagged<object>(obj).type())
  11         {
  12         case ALIEN_TYPE:
  13                 {
  14                         alien *ptr = untag<alien>(obj);
  15                         if(ptr->expired != F)
  16                                 general_error(ERROR_EXPIRED,obj,F,NULL);
  17                         return pinned_alien_offset(ptr->alien) + ptr->displacement;
  18                 }
  19         case F_TYPE:
  20                 return NULL;
  21         default:
  22                 type_error(ALIEN_TYPE,obj);
  23                 return NULL; /* can't happen */
  24         }
  25 }
  26
  27 /* make an alien */
  28 cell factor_vm::allot_alien(cell delegate_, cell displacement)
  29 {
  30         gc_root<object> delegate(delegate_,this);
  31         gc_root<alien> new_alien(allot<alien>(sizeof(alien)),this);
  32
  33         if(delegate.type_p(ALIEN_TYPE))
  34         {
  35                 tagged<alien> delegate_alien = delegate.as<alien>();
  36                 displacement += delegate_alien->displacement;
  37                 new_alien->alien = delegate_alien->alien;
  38         }
  39         else
  40                 new_alien->alien = delegate.value();
  41
  42         new_alien->displacement = displacement;
  43         new_alien->expired = F;
  44
  45         return new_alien.value();
  46 }
  47
  48 /* make an alien pointing at an offset of another alien */
  49 inline void factor_vm::primitive_displaced_alien()
  50 {
  51         cell alien = dpop();
  52         cell displacement = to_cell(dpop());
  53
  54         if(alien == F && displacement == 0)
  55                 dpush(F);
  56         else
  57         {
  58                 switch(tagged<object>(alien).type())
  59                 {
  60                 case BYTE_ARRAY_TYPE:
  61                 case ALIEN_TYPE:
  62                 case F_TYPE:
  63                         dpush(allot_alien(alien,displacement));
  64                         break;
  65                 default:
  66                         type_error(ALIEN_TYPE,alien);
  67                         break;
  68                 }
  69         }
  70 }
  71
  72 PRIMITIVE_FORWARD(displaced_alien)
  73
  74 /* address of an object representing a C pointer. Explicitly throw an error
  75 if the object is a byte array, as a sanity check. */
  76 inline void factor_vm::primitive_alien_address()
  77 {
  78         box_unsigned_cell((cell)pinned_alien_offset(dpop()));
  79 }
  80
  81 PRIMITIVE_FORWARD(alien_address)
  82
  83 /* pop ( alien n ) from datastack, return alien's address plus n */
  84 void *factor_vm::alien_pointer()
  85 {
  86         fixnum offset = to_fixnum(dpop());
  87         return unbox_alien() + offset;
  88 }
  89
  90 /* define words to read/write values at an alien address */
  91 #define DEFINE_ALIEN_ACCESSOR(name,type,boxer,to) \
  92         PRIMITIVE(alien_##name) \
  93         { \
  94                 PRIMITIVE_GETVM()->boxer(*(type*)PRIMITIVE_GETVM()->alien_pointer());   \
  95         } \
  96         PRIMITIVE(set_alien_##name) \
  97         { \
  98                 type *ptr = (type *)PRIMITIVE_GETVM()->alien_pointer(); \
  99                 type value = PRIMITIVE_GETVM()->to(dpop()); \
 100                 *ptr = value; \
 101         }
 102
 103 DEFINE_ALIEN_ACCESSOR(signed_cell,fixnum,box_signed_cell,to_fixnum)
 104 DEFINE_ALIEN_ACCESSOR(unsigned_cell,cell,box_unsigned_cell,to_cell)
 105 DEFINE_ALIEN_ACCESSOR(signed_8,s64,box_signed_8,to_signed_8)
 106 DEFINE_ALIEN_ACCESSOR(unsigned_8,u64,box_unsigned_8,to_unsigned_8)
 107 DEFINE_ALIEN_ACCESSOR(signed_4,s32,box_signed_4,to_fixnum)
 108 DEFINE_ALIEN_ACCESSOR(unsigned_4,u32,box_unsigned_4,to_cell)
 109 DEFINE_ALIEN_ACCESSOR(signed_2,s16,box_signed_2,to_fixnum)
 110 DEFINE_ALIEN_ACCESSOR(unsigned_2,u16,box_unsigned_2,to_cell)
 111 DEFINE_ALIEN_ACCESSOR(signed_1,s8,box_signed_1,to_fixnum)
 112 DEFINE_ALIEN_ACCESSOR(unsigned_1,u8,box_unsigned_1,to_cell)
 113 DEFINE_ALIEN_ACCESSOR(float,float,box_float,to_float)
 114 DEFINE_ALIEN_ACCESSOR(double,double,box_double,to_double)
 115 DEFINE_ALIEN_ACCESSOR(cell,void *,box_alien,pinned_alien_offset)
 116
 117 /* open a native library and push a handle */
 118 inline void factor_vm::primitive_dlopen()
 119 {
 120         gc_root<byte_array> path(dpop(),this);
 121         path.untag_check(this);
 122         gc_root<dll> library(allot<dll>(sizeof(dll)),this);
 123         library->path = path.value();
 124         ffi_dlopen(library.untagged());
 125         dpush(library.value());
 126 }
 127
 128 PRIMITIVE_FORWARD(dlopen)
 129
 130 /* look up a symbol in a native library */
 131 inline void factor_vm::primitive_dlsym()
 132 {
 133         gc_root<object> library(dpop(),this);
 134         gc_root<byte_array> name(dpop(),this);
 135         name.untag_check(this);
 136
 137         symbol_char *sym = name->data<symbol_char>();
 138
 139         if(library.value() == F)
 140                 box_alien(ffi_dlsym(NULL,sym));
 141         else
 142         {
 143                 dll *d = untag_check<dll>(library.value());
 144
 145                 if(d->dll == NULL)
 146                         dpush(F);
 147                 else
 148                         box_alien(ffi_dlsym(d,sym));
 149         }
 150 }
 151
 152 PRIMITIVE_FORWARD(dlsym)
 153
 154 /* close a native library handle */
 155 inline void factor_vm::primitive_dlclose()
 156 {
 157         dll *d = untag_check<dll>(dpop());
 158         if(d->dll != NULL)
 159                 ffi_dlclose(d);
 160 }
 161
 162 PRIMITIVE_FORWARD(dlclose)
 163
 164 inline void factor_vm::primitive_dll_validp()
 165 {
 166         cell library = dpop();
 167         if(library == F)
 168                 dpush(T);
 169         else
 170                 dpush(untag_check<dll>(library)->dll == NULL ? F : T);
 171 }
 172
 173 PRIMITIVE_FORWARD(dll_validp)
 174
 175 /* gets the address of an object representing a C pointer */
 176 char *factor_vm::alien_offset(cell obj)
 177 {
 178         switch(tagged<object>(obj).type())
 179         {
 180         case BYTE_ARRAY_TYPE:
 181                 return untag<byte_array>(obj)->data<char>();
 182         case ALIEN_TYPE:
 183                 {
 184                         alien *ptr = untag<alien>(obj);
 185                         if(ptr->expired != F)
 186                                 general_error(ERROR_EXPIRED,obj,F,NULL);
 187                         return alien_offset(ptr->alien) + ptr->displacement;
 188                 }
 189         case F_TYPE:
 190                 return NULL;
 191         default:
 192                 type_error(ALIEN_TYPE,obj);
 193                 return NULL; /* can't happen */
 194         }
 195 }
 196
 197 VM_C_API char *alien_offset(cell obj, factor_vm *myvm)
 198 {
 199         ASSERTVM();
 200         return VM_PTR->alien_offset(obj);
 201 }
 202
 203 /* pop an object representing a C pointer */
 204 char *factor_vm::unbox_alien()
 205 {
 206         return alien_offset(dpop());
 207 }
 208
 209 VM_C_API char *unbox_alien(factor_vm *myvm)
 210 {
 211         ASSERTVM();
 212         return VM_PTR->unbox_alien();
 213 }
 214
 215 /* make an alien and push */
 216 void factor_vm::box_alien(void *ptr)
 217 {
 218         if(ptr == NULL)
 219                 dpush(F);
 220         else
 221                 dpush(allot_alien(F,(cell)ptr));
 222 }
 223
 224 VM_C_API void box_alien(void *ptr, factor_vm *myvm)
 225 {
 226         ASSERTVM();
 227         return VM_PTR->box_alien(ptr);
 228 }
 229
 230 /* for FFI calls passing structs by value */
 231 void factor_vm::to_value_struct(cell src, void *dest, cell size)
 232 {
 233         memcpy(dest,alien_offset(src),size);
 234 }
 235
 236 VM_C_API void to_value_struct(cell src, void *dest, cell size, factor_vm *myvm)
 237 {
 238         ASSERTVM();
 239         return VM_PTR->to_value_struct(src,dest,size);
 240 }
 241
 242 /* for FFI callbacks receiving structs by value */
 243 void factor_vm::box_value_struct(void *src, cell size)
 244 {
 245         byte_array *bytes = allot_byte_array(size);
 246         memcpy(bytes->data<void>(),src,size);
 247         dpush(tag<byte_array>(bytes));
 248 }
 249
 250 VM_C_API void box_value_struct(void *src, cell size,factor_vm *myvm)
 251 {
 252         ASSERTVM();
 253         return VM_PTR->box_value_struct(src,size);
 254 }
 255
 256 /* On some x86 OSes, structs <= 8 bytes are returned in registers. */
 257 void factor_vm::box_small_struct(cell x, cell y, cell size)
 258 {
 259         cell data[2];
 260         data[0] = x;
 261         data[1] = y;
 262         box_value_struct(data,size);
 263 }
 264
 265 VM_C_API void box_small_struct(cell x, cell y, cell size, factor_vm *myvm)
 266 {
 267         ASSERTVM();
 268         return VM_PTR->box_small_struct(x,y,size);
 269 }
 270
 271 /* On OS X/PPC, complex numbers are returned in registers. */
 272 void factor_vm::box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
 273 {
 274         cell data[4];
 275         data[0] = x1;
 276         data[1] = x2;
 277         data[2] = x3;
 278         data[3] = x4;
 279         box_value_struct(data,size);
 280 }
 281
 282 VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factor_vm *myvm)
 283 {
 284         ASSERTVM();
 285         return VM_PTR->box_medium_struct(x1, x2, x3, x4, size);
 286 }
 287
 288 inline void factor_vm::primitive_vm_ptr()
 289 {
 290         box_alien(this);
 291 }
 292
 293 PRIMITIVE_FORWARD(vm_ptr)
 294
 295 }