vmpp/alien.cpp

   1 #include "master.hpp"
   2
   3 /* gets the address of an object representing a C pointer */
   4 char *alien_offset(CELL object)
   5 {
   6         F_ALIEN *alien;
   7         F_BYTE_ARRAY *byte_array;
   8
   9         switch(type_of(object))
  10         {
  11         case BYTE_ARRAY_TYPE:
  12                 byte_array = untagged<F_BYTE_ARRAY>(object);
  13                 return (char *)(byte_array + 1);
  14         case ALIEN_TYPE:
  15                 alien = untagged<F_ALIEN>(object);
  16                 if(alien->expired != F)
  17                         general_error(ERROR_EXPIRED,object,F,NULL);
  18                 return alien_offset(alien->alien) + alien->displacement;
  19         case F_TYPE:
  20                 return NULL;
  21         default:
  22                 type_error(ALIEN_TYPE,object);
  23                 return NULL; /* can't happen */
  24         }
  25 }
  26
  27 /* gets the address of an object representing a C pointer, with the
  28 intention of storing the pointer across code which may potentially GC. */
  29 char *pinned_alien_offset(CELL object)
  30 {
  31         F_ALIEN *alien;
  32
  33         switch(type_of(object))
  34         {
  35         case ALIEN_TYPE:
  36                 alien = untagged<F_ALIEN>(object);
  37                 if(alien->expired != F)
  38                         general_error(ERROR_EXPIRED,object,F,NULL);
  39                 return pinned_alien_offset(alien->alien) + alien->displacement;
  40         case F_TYPE:
  41                 return NULL;
  42         default:
  43                 type_error(ALIEN_TYPE,object);
  44                 return NULL; /* can't happen */
  45         }
  46 }
  47
  48 /* pop an object representing a C pointer */
  49 char *unbox_alien(void)
  50 {
  51         return alien_offset(dpop());
  52 }
  53
  54 /* make an alien */
  55 CELL allot_alien(CELL delegate_, CELL displacement)
  56 {
  57         gc_root<F_OBJECT> delegate(delegate_);
  58         gc_root<F_ALIEN> alien(allot<F_ALIEN>(sizeof(F_ALIEN)));
  59
  60         if(delegate.isa(ALIEN_TYPE))
  61         {
  62                 tagged<F_ALIEN> delegate_alien = delegate.as<F_ALIEN>();
  63                 displacement += delegate_alien->displacement;
  64                 alien->alien = delegate_alien->alien;
  65         }
  66         else
  67                 alien->alien = delegate.value();
  68
  69         alien->displacement = displacement;
  70         alien->expired = F;
  71
  72         return alien.value();
  73 }
  74
  75 /* make an alien and push */
  76 void box_alien(void *ptr)
  77 {
  78         if(ptr == NULL)
  79                 dpush(F);
  80         else
  81                 dpush(allot_alien(F,(CELL)ptr));
  82 }
  83
  84 /* make an alien pointing at an offset of another alien */
  85 void primitive_displaced_alien(void)
  86 {
  87         CELL alien = dpop();
  88         CELL displacement = to_cell(dpop());
  89
  90         if(alien == F && displacement == 0)
  91                 dpush(F);
  92         else
  93         {
  94                 switch(type_of(alien))
  95                 {
  96                 case BYTE_ARRAY_TYPE:
  97                 case ALIEN_TYPE:
  98                 case F_TYPE:
  99                         dpush(allot_alien(alien,displacement));
 100                         break;
 101                 default:
 102                         type_error(ALIEN_TYPE,alien);
 103                         break;
 104                 }
 105         }
 106 }
 107
 108 /* address of an object representing a C pointer. Explicitly throw an error
 109 if the object is a byte array, as a sanity check. */
 110 void primitive_alien_address(void)
 111 {
 112         box_unsigned_cell((CELL)pinned_alien_offset(dpop()));
 113 }
 114
 115 /* pop ( alien n ) from datastack, return alien's address plus n */
 116 INLINE void *alien_pointer(void)
 117 {
 118         F_FIXNUM offset = to_fixnum(dpop());
 119         return unbox_alien() + offset;
 120 }
 121
 122 /* define words to read/write values at an alien address */
 123 #define DEFINE_ALIEN_ACCESSOR(name,type,boxer,to) \
 124         void primitive_alien_##name(void) \
 125         { \
 126                 boxer(*(type*)alien_pointer()); \
 127         } \
 128         void primitive_set_alien_##name(void) \
 129         { \
 130                 type *ptr = (type *)alien_pointer(); \
 131                 type value = to(dpop()); \
 132                 *ptr = value; \
 133         }
 134
 135 DEFINE_ALIEN_ACCESSOR(signed_cell,F_FIXNUM,box_signed_cell,to_fixnum)
 136 DEFINE_ALIEN_ACCESSOR(unsigned_cell,CELL,box_unsigned_cell,to_cell)
 137 DEFINE_ALIEN_ACCESSOR(signed_8,s64,box_signed_8,to_signed_8)
 138 DEFINE_ALIEN_ACCESSOR(unsigned_8,u64,box_unsigned_8,to_unsigned_8)
 139 DEFINE_ALIEN_ACCESSOR(signed_4,s32,box_signed_4,to_fixnum)
 140 DEFINE_ALIEN_ACCESSOR(unsigned_4,u32,box_unsigned_4,to_cell)
 141 DEFINE_ALIEN_ACCESSOR(signed_2,s16,box_signed_2,to_fixnum)
 142 DEFINE_ALIEN_ACCESSOR(unsigned_2,u16,box_unsigned_2,to_cell)
 143 DEFINE_ALIEN_ACCESSOR(signed_1,s8,box_signed_1,to_fixnum)
 144 DEFINE_ALIEN_ACCESSOR(unsigned_1,u8,box_unsigned_1,to_cell)
 145 DEFINE_ALIEN_ACCESSOR(float,float,box_float,to_float)
 146 DEFINE_ALIEN_ACCESSOR(double,double,box_double,to_double)
 147 DEFINE_ALIEN_ACCESSOR(cell,void *,box_alien,pinned_alien_offset)
 148
 149 /* for FFI calls passing structs by value */
 150 void to_value_struct(CELL src, void *dest, CELL size)
 151 {
 152         memcpy(dest,alien_offset(src),size);
 153 }
 154
 155 /* for FFI callbacks receiving structs by value */
 156 void box_value_struct(void *src, CELL size)
 157 {
 158         F_BYTE_ARRAY *array = allot_byte_array(size);
 159         memcpy(array + 1,src,size);
 160         dpush(tag_object(array));
 161 }
 162
 163 /* On some x86 OSes, structs <= 8 bytes are returned in registers. */
 164 void box_small_struct(CELL x, CELL y, CELL size)
 165 {
 166         CELL data[2];
 167         data[0] = x;
 168         data[1] = y;
 169         box_value_struct(data,size);
 170 }
 171
 172 /* On OS X/PPC, complex numbers are returned in registers. */
 173 void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size)
 174 {
 175         CELL data[4];
 176         data[0] = x1;
 177         data[1] = x2;
 178         data[2] = x3;
 179         data[3] = x4;
 180         box_value_struct(data,size);
 181 }
 182
 183 /* open a native library and push a handle */
 184 void primitive_dlopen(void)
 185 {
 186         gc_root<F_BYTE_ARRAY> path(tag_object(string_to_native_alien(untag_string(dpop()))));
 187         gc_root<F_DLL> dll(allot<F_DLL>(sizeof(F_DLL)));
 188         dll->path = path.value();
 189         ffi_dlopen(dll.untagged());
 190         dpush(dll.value());
 191 }
 192
 193 /* look up a symbol in a native library */
 194 void primitive_dlsym(void)
 195 {
 196         gc_root<F_OBJECT> dll(dpop());
 197         F_SYMBOL *sym = unbox_symbol_string();
 198
 199         if(dll.value() == F)
 200                 box_alien(ffi_dlsym(NULL,sym));
 201         else
 202         {
 203                 tagged<F_DLL> d = dll.as<F_DLL>();
 204                 if(d->dll == NULL)
 205                         dpush(F);
 206                 else
 207                         box_alien(ffi_dlsym(d.untagged(),sym));
 208         }
 209 }
 210
 211 /* close a native library handle */
 212 void primitive_dlclose(void)
 213 {
 214         ffi_dlclose(untag_dll(dpop()));
 215 }
 216
 217 void primitive_dll_validp(void)
 218 {
 219         CELL dll = dpop();
 220         if(dll == F)
 221                 dpush(T);
 222         else
 223                 dpush(tagged<F_DLL>(dll)->dll == NULL ? F : T);
 224 }