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