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