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