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