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