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                         if(to_boolean(ptr->base))
  18                                 type_error(ALIEN_TYPE,obj);
  19                         else
  20                                 return (char *)ptr->address;
  21                 }
  22         case F_TYPE:
  23                 return NULL;
  24         default:
  25                 type_error(ALIEN_TYPE,obj);
  26                 return NULL; /* can't happen */
  27         }
  28 }
  29
  30 /* make an alien */
  31 cell factor_vm::allot_alien(cell delegate_, cell displacement)
  32 {
  33         gc_root<object> delegate(delegate_,this);
  34         gc_root<alien> new_alien(allot<alien>(sizeof(alien)),this);
  35
  36         if(delegate.type_p(ALIEN_TYPE))
  37         {
  38                 tagged<alien> delegate_alien = delegate.as<alien>();
  39                 displacement += delegate_alien->displacement;
  40                 new_alien->base = delegate_alien->base;
  41         }
  42         else
  43                 new_alien->base = delegate.value();
  44
  45         new_alien->displacement = displacement;
  46         new_alien->expired = false_object;
  47         new_alien->update_address();
  48
  49         return new_alien.value();
  50 }
  51
  52 /* make an alien pointing at an offset of another alien */
  53 void factor_vm::primitive_displaced_alien()
  54 {
  55         cell alien = dpop();
  56         cell displacement = to_cell(dpop());
  57
  58         if(!to_boolean(alien) && displacement == 0)
  59                 dpush(false_object);
  60         else
  61         {
  62                 switch(tagged<object>(alien).type())
  63                 {
  64                 case BYTE_ARRAY_TYPE:
  65                 case ALIEN_TYPE:
  66                 case F_TYPE:
  67                         dpush(allot_alien(alien,displacement));
  68                         break;
  69                 default:
  70                         type_error(ALIEN_TYPE,alien);
  71                         break;
  72                 }
  73         }
  74 }
  75
  76 /* address of an object representing a C pointer. Explicitly throw an error
  77 if the object is a byte array, as a sanity check. */
  78 void factor_vm::primitive_alien_address()
  79 {
  80         box_unsigned_cell((cell)pinned_alien_offset(dpop()));
  81 }
  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                 parent->boxer(*(type*)(parent->alien_pointer())); \
  95         } \
  96         PRIMITIVE(set_alien_##name) \
  97         { \
  98                 type *ptr = (type *)parent->alien_pointer(); \
  99                 type value = parent->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 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 /* look up a symbol in a native library */
 129 void factor_vm::primitive_dlsym()
 130 {
 131         gc_root<object> library(dpop(),this);
 132         gc_root<byte_array> name(dpop(),this);
 133         name.untag_check(this);
 134
 135         symbol_char *sym = name->data<symbol_char>();
 136
 137         if(to_boolean(library.value()))
 138         {
 139                 dll *d = untag_check<dll>(library.value());
 140
 141                 if(d->dll == NULL)
 142                         dpush(false_object);
 143                 else
 144                         box_alien(ffi_dlsym(d,sym));
 145         }
 146         else
 147                 box_alien(ffi_dlsym(NULL,sym));
 148 }
 149
 150 /* close a native library handle */
 151 void factor_vm::primitive_dlclose()
 152 {
 153         dll *d = untag_check<dll>(dpop());
 154         if(d->dll != NULL)
 155                 ffi_dlclose(d);
 156 }
 157
 158 void factor_vm::primitive_dll_validp()
 159 {
 160         cell library = dpop();
 161         if(to_boolean(library))
 162                 dpush(tag_boolean(untag_check<dll>(library)->dll != NULL));
 163         else
 164                 dpush(true_object);
 165 }
 166
 167 /* gets the address of an object representing a C pointer */
 168 char *factor_vm::alien_offset(cell obj)
 169 {
 170         switch(tagged<object>(obj).type())
 171         {
 172         case BYTE_ARRAY_TYPE:
 173                 return untag<byte_array>(obj)->data<char>();
 174         case ALIEN_TYPE:
 175                 return (char *)untag<alien>(obj)->address;
 176         case F_TYPE:
 177                 return NULL;
 178         default:
 179                 type_error(ALIEN_TYPE,obj);
 180                 return NULL; /* can't happen */
 181         }
 182 }
 183
 184 VM_C_API char *alien_offset(cell obj, factor_vm *parent)
 185 {
 186         return parent->alien_offset(obj);
 187 }
 188
 189 /* pop an object representing a C pointer */
 190 char *factor_vm::unbox_alien()
 191 {
 192         return alien_offset(dpop());
 193 }
 194
 195 VM_C_API char *unbox_alien(factor_vm *parent)
 196 {
 197         return parent->unbox_alien();
 198 }
 199
 200 /* make an alien and push */
 201 void factor_vm::box_alien(void *ptr)
 202 {
 203         if(ptr == NULL)
 204                 dpush(false_object);
 205         else
 206                 dpush(allot_alien(false_object,(cell)ptr));
 207 }
 208
 209 VM_C_API void box_alien(void *ptr, factor_vm *parent)
 210 {
 211         return parent->box_alien(ptr);
 212 }
 213
 214 /* for FFI calls passing structs by value */
 215 void factor_vm::to_value_struct(cell src, void *dest, cell size)
 216 {
 217         memcpy(dest,alien_offset(src),size);
 218 }
 219
 220 VM_C_API void to_value_struct(cell src, void *dest, cell size, factor_vm *parent)
 221 {
 222         return parent->to_value_struct(src,dest,size);
 223 }
 224
 225 /* for FFI callbacks receiving structs by value */
 226 void factor_vm::box_value_struct(void *src, cell size)
 227 {
 228         byte_array *bytes = allot_byte_array(size);
 229         memcpy(bytes->data<void>(),src,size);
 230         dpush(tag<byte_array>(bytes));
 231 }
 232
 233 VM_C_API void box_value_struct(void *src, cell size,factor_vm *parent)
 234 {
 235         return parent->box_value_struct(src,size);
 236 }
 237
 238 /* On some x86 OSes, structs <= 8 bytes are returned in registers. */
 239 void factor_vm::box_small_struct(cell x, cell y, cell size)
 240 {
 241         cell data[2];
 242         data[0] = x;
 243         data[1] = y;
 244         box_value_struct(data,size);
 245 }
 246
 247 VM_C_API void box_small_struct(cell x, cell y, cell size, factor_vm *parent)
 248 {
 249         return parent->box_small_struct(x,y,size);
 250 }
 251
 252 /* On OS X/PPC, complex numbers are returned in registers. */
 253 void factor_vm::box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
 254 {
 255         cell data[4];
 256         data[0] = x1;
 257         data[1] = x2;
 258         data[2] = x3;
 259         data[3] = x4;
 260         box_value_struct(data,size);
 261 }
 262
 263 VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factor_vm *parent)
 264 {
 265         return parent->box_medium_struct(x1, x2, x3, x4, size);
 266 }
 267
 268 void factor_vm::primitive_vm_ptr()
 269 {
 270         box_alien(this);
 271 }
 272
 273 }