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);
  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(displacement == 0)
  39                 return delegate_;
  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         VM_C_API void primitive_alien_##name(factor_vm *parent) \
 106         { \
 107                 parent->ctx->push(parent->from(*(type*)(parent->alien_pointer()))); \
 108         } \
 109         VM_C_API void primitive_set_alien_##name(factor_vm *parent) \
 110         { \
 111                 type *ptr = (type *)parent->alien_pointer(); \
 112                 type value = (type)parent->to(parent->ctx->pop()); \
 113                 *ptr = value; \
 114         }
 115
 116 EACH_ALIEN_PRIMITIVE(DEFINE_ALIEN_ACCESSOR)
 117
 118 /* open a native library and push a handle */
 119 void factor_vm::primitive_dlopen()
 120 {
 121         data_root<byte_array> path(ctx->pop(),this);
 122         path.untag_check(this);
 123         data_root<dll> library(allot<dll>(sizeof(dll)),this);
 124         library->path = path.value();
 125         ffi_dlopen(library.untagged());
 126         ctx->push(library.value());
 127 }
 128
 129 /* look up a symbol in a native library */
 130 void factor_vm::primitive_dlsym()
 131 {
 132         data_root<object> library(ctx->pop(),this);
 133         data_root<byte_array> name(ctx->pop(),this);
 134         name.untag_check(this);
 135
 136         symbol_char *sym = name->data<symbol_char>();
 137
 138         if(to_boolean(library.value()))
 139         {
 140                 dll *d = untag_check<dll>(library.value());
 141
 142                 if(d->handle == NULL)
 143                         ctx->push(false_object);
 144                 else
 145                         ctx->push(allot_alien(ffi_dlsym(d,sym)));
 146         }
 147         else
 148                 ctx->push(allot_alien(ffi_dlsym(NULL,sym)));
 149 }
 150
 151 /* close a native library handle */
 152 void factor_vm::primitive_dlclose()
 153 {
 154         dll *d = untag_check<dll>(ctx->pop());
 155         if(d->handle != NULL)
 156                 ffi_dlclose(d);
 157 }
 158
 159 void factor_vm::primitive_dll_validp()
 160 {
 161         cell library = ctx->pop();
 162         if(to_boolean(library))
 163                 ctx->push(tag_boolean(untag_check<dll>(library)->handle != NULL));
 164         else
 165                 ctx->push(true_object);
 166 }
 167
 168 /* gets the address of an object representing a C pointer */
 169 char *factor_vm::alien_offset(cell obj)
 170 {
 171         switch(tagged<object>(obj).type())
 172         {
 173         case BYTE_ARRAY_TYPE:
 174                 return untag<byte_array>(obj)->data<char>();
 175         case ALIEN_TYPE:
 176                 return (char *)untag<alien>(obj)->address;
 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 /* For FFI callbacks receiving structs by value */
 191 cell factor_vm::from_value_struct(void *src, cell size)
 192 {
 193         byte_array *bytes = allot_byte_array(size);
 194         memcpy(bytes->data<void>(),src,size);
 195         return tag<byte_array>(bytes);
 196 }
 197
 198 VM_C_API cell from_value_struct(void *src, cell size, factor_vm *parent)
 199 {
 200         return parent->from_value_struct(src,size);
 201 }
 202
 203 /* On some x86 OSes, structs <= 8 bytes are returned in registers. */
 204 cell factor_vm::from_small_struct(cell x, cell y, cell size)
 205 {
 206         cell data[2];
 207         data[0] = x;
 208         data[1] = y;
 209         return from_value_struct(data,size);
 210 }
 211
 212 VM_C_API cell from_small_struct(cell x, cell y, cell size, factor_vm *parent)
 213 {
 214         return parent->from_small_struct(x,y,size);
 215 }
 216
 217 /* On OS X/PPC, complex numbers are returned in registers. */
 218 cell factor_vm::from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
 219 {
 220         cell data[4];
 221         data[0] = x1;
 222         data[1] = x2;
 223         data[2] = x3;
 224         data[3] = x4;
 225         return from_value_struct(data,size);
 226 }
 227
 228 VM_C_API cell from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factor_vm *parent)
 229 {
 230         return parent->from_medium_struct(x1, x2, x3, x4, size);
 231 }
 232
 233 }