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 VM_C_API char *pinned_alien_offset(cell obj, factor_vm *parent)
  31 {
  32         return parent->pinned_alien_offset(obj);
  33 }
  34
  35 /* make an alien */
  36 cell factor_vm::allot_alien(cell delegate_, cell displacement)
  37 {
  38         if(delegate_ == false_object && displacement == 0)
  39                 return false_object;
  40
  41         data_root<object> delegate(delegate_,this);
  42         data_root<alien> new_alien(allot<alien>(sizeof(alien)),this);
  43
  44         if(delegate.type_p(ALIEN_TYPE))
  45         {
  46                 tagged<alien> delegate_alien = delegate.as<alien>();
  47                 displacement += delegate_alien->displacement;
  48                 new_alien->base = delegate_alien->base;
  49         }
  50         else
  51                 new_alien->base = delegate.value();
  52
  53         new_alien->displacement = displacement;
  54         new_alien->expired = false_object;
  55         new_alien->update_address();
  56
  57         return new_alien.value();
  58 }
  59
  60 cell factor_vm::allot_alien(void *address)
  61 {
  62         return allot_alien(false_object,(cell)address);
  63 }
  64
  65 VM_C_API cell allot_alien(void *address, factor_vm *vm)
  66 {
  67         return vm->allot_alien(address);
  68 }
  69
  70 /* make an alien pointing at an offset of another alien */
  71 void factor_vm::primitive_displaced_alien()
  72 {
  73         cell alien = ctx->pop();
  74         cell displacement = to_cell(ctx->pop());
  75
  76         switch(tagged<object>(alien).type())
  77         {
  78         case BYTE_ARRAY_TYPE:
  79         case ALIEN_TYPE:
  80         case F_TYPE:
  81                 ctx->push(allot_alien(alien,displacement));
  82                 break;
  83         default:
  84                 type_error(ALIEN_TYPE,alien);
  85                 break;
  86         }
  87 }
  88
  89 /* address of an object representing a C pointer. Explicitly throw an error
  90 if the object is a byte array, as a sanity check. */
  91 void factor_vm::primitive_alien_address()
  92 {
  93         ctx->push(allot_cell((cell)pinned_alien_offset(ctx->pop())));
  94 }
  95
  96 /* pop ( alien n ) from datastack, return alien's address plus n */
  97 void *factor_vm::alien_pointer()
  98 {
  99         fixnum offset = to_fixnum(ctx->pop());
 100         return alien_offset(ctx->pop()) + offset;
 101 }
 102
 103 /* define words to read/write values at an alien address */
 104 #define DEFINE_ALIEN_ACCESSOR(name,type,from,to) \
 105         PRIMITIVE(alien_##name) \
 106         { \
 107                 parent->ctx->push(from(*(type*)(parent->alien_pointer()),parent)); \
 108         } \
 109         PRIMITIVE(set_alien_##name) \
 110         { \
 111                 type *ptr = (type *)parent->alien_pointer(); \
 112                 type value = to(parent->ctx->pop(),parent); \
 113                 *ptr = value; \
 114         }
 115
 116 DEFINE_ALIEN_ACCESSOR(signed_cell,fixnum,from_signed_cell,to_fixnum)
 117 DEFINE_ALIEN_ACCESSOR(unsigned_cell,cell,from_unsigned_cell,to_cell)
 118 DEFINE_ALIEN_ACCESSOR(signed_8,s64,from_signed_8,to_signed_8)
 119 DEFINE_ALIEN_ACCESSOR(unsigned_8,u64,from_unsigned_8,to_unsigned_8)
 120 DEFINE_ALIEN_ACCESSOR(signed_4,s32,from_signed_4,to_fixnum)
 121 DEFINE_ALIEN_ACCESSOR(unsigned_4,u32,from_unsigned_4,to_cell)
 122 DEFINE_ALIEN_ACCESSOR(signed_2,s16,from_signed_2,to_fixnum)
 123 DEFINE_ALIEN_ACCESSOR(unsigned_2,u16,from_unsigned_2,to_cell)
 124 DEFINE_ALIEN_ACCESSOR(signed_1,s8,from_signed_1,to_fixnum)
 125 DEFINE_ALIEN_ACCESSOR(unsigned_1,u8,from_unsigned_1,to_cell)
 126 DEFINE_ALIEN_ACCESSOR(float,float,from_float,to_float)
 127 DEFINE_ALIEN_ACCESSOR(double,double,from_double,to_double)
 128 DEFINE_ALIEN_ACCESSOR(cell,void *,allot_alien,pinned_alien_offset)
 129
 130 /* open a native library and push a handle */
 131 void factor_vm::primitive_dlopen()
 132 {
 133         data_root<byte_array> path(ctx->pop(),this);
 134         path.untag_check(this);
 135         data_root<dll> library(allot<dll>(sizeof(dll)),this);
 136         library->path = path.value();
 137         ffi_dlopen(library.untagged());
 138         ctx->push(library.value());
 139 }
 140
 141 /* look up a symbol in a native library */
 142 void factor_vm::primitive_dlsym()
 143 {
 144         data_root<object> library(ctx->pop(),this);
 145         data_root<byte_array> name(ctx->pop(),this);
 146         name.untag_check(this);
 147
 148         symbol_char *sym = name->data<symbol_char>();
 149
 150         if(to_boolean(library.value()))
 151         {
 152                 dll *d = untag_check<dll>(library.value());
 153
 154                 if(d->dll == NULL)
 155                         ctx->push(false_object);
 156                 else
 157                         ctx->push(allot_alien(ffi_dlsym(d,sym)));
 158         }
 159         else
 160                 ctx->push(allot_alien(ffi_dlsym(NULL,sym)));
 161 }
 162
 163 /* close a native library handle */
 164 void factor_vm::primitive_dlclose()
 165 {
 166         dll *d = untag_check<dll>(ctx->pop());
 167         if(d->dll != NULL)
 168                 ffi_dlclose(d);
 169 }
 170
 171 void factor_vm::primitive_dll_validp()
 172 {
 173         cell library = ctx->pop();
 174         if(to_boolean(library))
 175                 ctx->push(tag_boolean(untag_check<dll>(library)->dll != NULL));
 176         else
 177                 ctx->push(true_object);
 178 }
 179
 180 /* gets the address of an object representing a C pointer */
 181 char *factor_vm::alien_offset(cell obj)
 182 {
 183         switch(tagged<object>(obj).type())
 184         {
 185         case BYTE_ARRAY_TYPE:
 186                 return untag<byte_array>(obj)->data<char>();
 187         case ALIEN_TYPE:
 188                 return (char *)untag<alien>(obj)->address;
 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 *parent)
 198 {
 199         return parent->alien_offset(obj);
 200 }
 201
 202 /* For FFI calls passing structs by value. Cannot allocate */
 203 void factor_vm::to_value_struct(cell src, void *dest, cell size)
 204 {
 205         memcpy(dest,alien_offset(src),size);
 206 }
 207
 208 VM_C_API void to_value_struct(cell src, void *dest, cell size, factor_vm *parent)
 209 {
 210         return parent->to_value_struct(src,dest,size);
 211 }
 212
 213 /* For FFI callbacks receiving structs by value */
 214 cell factor_vm::from_value_struct(void *src, cell size)
 215 {
 216         byte_array *bytes = allot_byte_array(size);
 217         memcpy(bytes->data<void>(),src,size);
 218         return tag<byte_array>(bytes);
 219 }
 220
 221 VM_C_API cell from_value_struct(void *src, cell size, factor_vm *parent)
 222 {
 223         return parent->from_value_struct(src,size);
 224 }
 225
 226 /* On some x86 OSes, structs <= 8 bytes are returned in registers. */
 227 cell factor_vm::from_small_struct(cell x, cell y, cell size)
 228 {
 229         cell data[2];
 230         data[0] = x;
 231         data[1] = y;
 232         return from_value_struct(data,size);
 233 }
 234
 235 VM_C_API cell from_small_struct(cell x, cell y, cell size, factor_vm *parent)
 236 {
 237         return parent->from_small_struct(x,y,size);
 238 }
 239
 240 /* On OS X/PPC, complex numbers are returned in registers. */
 241 cell factor_vm::from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
 242 {
 243         cell data[4];
 244         data[0] = x1;
 245         data[1] = x2;
 246         data[2] = x3;
 247         data[3] = x4;
 248         return from_value_struct(data,size);
 249 }
 250
 251 VM_C_API cell from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factor_vm *parent)
 252 {
 253         return parent->from_medium_struct(x1, x2, x3, x4, size);
 254 }
 255
 256 void factor_vm::primitive_vm_ptr()
 257 {
 258         ctx->push(allot_alien(this));
 259 }
 260
 261 }