vm/alien.cpp

   1 #include "master.hpp"
   2
   3 namespace factor {
   4
   5 // gets the address of an object representing a C pointer, with the
   6 // intention of storing the pointer across code which may potentially GC.
   7 char* factor_vm::pinned_alien_offset(cell obj) {
   8   switch (TAG(obj)) {
   9     case ALIEN_TYPE: {
  10       alien* ptr = untag<alien>(obj);
  11       if (to_boolean(ptr->expired))
  12         general_error(ERROR_EXPIRED, obj, false_object);
  13       if (to_boolean(ptr->base))
  14         type_error(ALIEN_TYPE, obj);
  15       else
  16         return (char*)ptr->address;
  17     }
  18     case F_TYPE:
  19       return NULL;
  20     default:
  21       type_error(ALIEN_TYPE, obj);
  22       return NULL; // can't happen
  23   }
  24 }
  25
  26 // make an alien
  27 // Allocates memory
  28 cell factor_vm::allot_alien(cell delegate_, cell displacement) {
  29   if (displacement == 0)
  30     return delegate_;
  31
  32   data_root<object> delegate(delegate_, this);
  33   data_root<alien> new_alien(allot<alien>(sizeof(alien)), this);
  34
  35   if (delegate.type() == ALIEN_TYPE) {
  36     tagged<alien> delegate_alien = delegate.as<alien>();
  37     displacement += delegate_alien->displacement;
  38     new_alien->base = delegate_alien->base;
  39   } else
  40     new_alien->base = delegate.value();
  41
  42   new_alien->displacement = displacement;
  43   new_alien->expired = false_object;
  44   new_alien->update_address();
  45
  46   return new_alien.value();
  47 }
  48
  49 // Allocates memory
  50 cell factor_vm::allot_alien(cell address) {
  51   return allot_alien(false_object, address);
  52 }
  53
  54 // make an alien pointing at an offset of another alien
  55 // Allocates memory
  56 void factor_vm::primitive_displaced_alien() {
  57   cell alien = ctx->pop();
  58   cell displacement = to_cell(ctx->pop());
  59
  60   switch (TAG(alien)) {
  61     case BYTE_ARRAY_TYPE:
  62     case ALIEN_TYPE:
  63     case F_TYPE:
  64       ctx->push(allot_alien(alien, displacement));
  65       break;
  66     default:
  67       type_error(ALIEN_TYPE, alien);
  68       break;
  69   }
  70 }
  71
  72 // address of an object representing a C pointer. Explicitly throw an error
  73 // if the object is a byte array, as a sanity check.
  74 // Allocates memory (from_unsigned_cell can allocate)
  75 void factor_vm::primitive_alien_address() {
  76   ctx->replace(from_unsigned_cell((cell)pinned_alien_offset(ctx->peek())));
  77 }
  78
  79 // pop ( alien n ) from datastack, return alien's address plus n
  80 void* factor_vm::alien_pointer() {
  81   fixnum offset = to_fixnum(ctx->pop());
  82   return alien_offset(ctx->pop()) + offset;
  83 }
  84
  85 // define words to read/write values at an alien address
  86 #define DEFINE_ALIEN_ACCESSOR(name, type, from, to)                     \
  87   VM_C_API void primitive_alien_##name(factor_vm * parent) {            \
  88     parent->ctx->push(parent->from(*(type*)(parent->alien_pointer()))); \
  89   }                                                                     \
  90   VM_C_API void primitive_set_alien_##name(factor_vm * parent) {        \
  91     type* ptr = (type*)parent->alien_pointer();                         \
  92     type value = (type)parent->to(parent->ctx->pop());                  \
  93     *ptr = value;                                                       \
  94   }
  95
  96 EACH_ALIEN_PRIMITIVE(DEFINE_ALIEN_ACCESSOR)
  97
  98 // open a native library and push a handle
  99 // Allocates memory
 100 void factor_vm::primitive_dlopen() {
 101   data_root<byte_array> path(ctx->pop(), this);
 102   path.untag_check(this);
 103   data_root<dll> library(allot<dll>(sizeof(dll)), this);
 104   library->path = path.value();
 105   ffi_dlopen(library.untagged());
 106   ctx->push(library.value());
 107 }
 108
 109 // look up a symbol in a native library
 110 // Allocates memory
 111 void factor_vm::primitive_dlsym() {
 112   data_root<object> library(ctx->pop(), this);
 113   data_root<byte_array> name(ctx->peek(), this);
 114   name.untag_check(this);
 115
 116   symbol_char* sym = name->data<symbol_char>();
 117
 118   if (to_boolean(library.value())) {
 119     dll* d = untag_check<dll>(library.value());
 120
 121     if (d->handle == NULL)
 122       ctx->replace(false_object);
 123     else
 124       ctx->replace(allot_alien(ffi_dlsym(d, sym)));
 125   } else
 126     ctx->replace(allot_alien(ffi_dlsym(NULL, sym)));
 127 }
 128
 129 // look up a symbol in a native library
 130 // Allocates memory
 131 void factor_vm::primitive_dlsym_raw() {
 132   data_root<object> library(ctx->pop(), this);
 133   data_root<byte_array> name(ctx->peek(), this);
 134   name.untag_check(this);
 135
 136   symbol_char* sym = name->data<symbol_char>();
 137
 138   if (to_boolean(library.value())) {
 139     dll* d = untag_check<dll>(library.value());
 140
 141     if (d->handle == NULL)
 142       ctx->replace(false_object);
 143     else
 144       ctx->replace(allot_alien(ffi_dlsym_raw(d, sym)));
 145   } else
 146     ctx->replace(allot_alien(ffi_dlsym_raw(NULL, sym)));
 147 }
 148
 149 // close a native library handle
 150 void factor_vm::primitive_dlclose() {
 151   dll* d = untag_check<dll>(ctx->pop());
 152   if (d->handle != NULL)
 153     ffi_dlclose(d);
 154 }
 155
 156 void factor_vm::primitive_dll_validp() {
 157   cell library = ctx->peek();
 158   if (to_boolean(library))
 159     ctx->replace(tag_boolean(untag_check<dll>(library)->handle != NULL));
 160   else
 161     ctx->replace(special_objects[OBJ_CANONICAL_TRUE]);
 162 }
 163
 164 // gets the address of an object representing a C pointer
 165 char* factor_vm::alien_offset(cell obj) {
 166   switch (TAG(obj)) {
 167     case BYTE_ARRAY_TYPE:
 168       return untag<byte_array>(obj)->data<char>();
 169     case ALIEN_TYPE:
 170       return (char*)untag<alien>(obj)->address;
 171     case F_TYPE:
 172       return NULL;
 173     default:
 174       type_error(ALIEN_TYPE, obj);
 175       return NULL; // can't happen
 176   }
 177 }
 178
 179 }