vm/alien.c

   1 #include "master.h"
   2
   3 /* gets the address of an object representing a C pointer */
   4 void *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 = untag_object(object);
  13                 return byte_array + 1;
  14         case ALIEN_TYPE:
  15                 alien = untag_object(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 void *pinned_alien_offset(CELL object)
  30 {
  31         F_ALIEN *alien;
  32
  33         switch(type_of(object))
  34         {
  35         case ALIEN_TYPE:
  36                 alien = untag_object(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 void *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         REGISTER_ROOT(delegate);
  58         F_ALIEN *alien = allot_object(ALIEN_TYPE,sizeof(F_ALIEN));
  59         UNREGISTER_ROOT(delegate);
  60
  61         if(type_of(delegate) == ALIEN_TYPE)
  62         {
  63                 F_ALIEN *delegate_alien = untag_object(delegate);
  64                 displacement += delegate_alien->displacement;
  65                 alien->alien = delegate_alien->alien;
  66         }
  67         else
  68                 alien->alien = delegate;
  69
  70         alien->displacement = displacement;
  71         alien->expired = F;
  72         return tag_object(alien);
  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 = 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 OS X, 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 /* open a native library and push a handle */
 173 void primitive_dlopen(void)
 174 {
 175         CELL path = tag_object(string_to_native_alien(
 176                 untag_string(dpop())));
 177         REGISTER_ROOT(path);
 178         F_DLL* dll = allot_object(DLL_TYPE,sizeof(F_DLL));
 179         UNREGISTER_ROOT(path);
 180         dll->path = path;
 181         ffi_dlopen(dll);
 182         dpush(tag_object(dll));
 183 }
 184
 185 /* look up a symbol in a native library */
 186 void primitive_dlsym(void)
 187 {
 188         CELL dll = dpop();
 189         REGISTER_ROOT(dll);
 190         F_SYMBOL *sym = unbox_symbol_string();
 191         UNREGISTER_ROOT(dll);
 192
 193         F_DLL *d;
 194
 195         if(dll == F)
 196                 box_alien(ffi_dlsym(NULL,sym));
 197         else
 198         {
 199                 d = untag_dll(dll);
 200                 if(d->dll == NULL)
 201                         dpush(F);
 202                 else
 203                         box_alien(ffi_dlsym(d,sym));
 204         }
 205 }
 206
 207 /* close a native library handle */
 208 void primitive_dlclose(void)
 209 {
 210         ffi_dlclose(untag_dll(dpop()));
 211 }
 212
 213 void primitive_dll_validp(void)
 214 {
 215         CELL dll = dpop();
 216         if(dll == F)
 217                 dpush(T);
 218         else
 219         {
 220                 F_DLL *d = untag_dll(dll);
 221                 dpush(d->dll == NULL ? F : T);
 222         }
 223 }