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