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)
10 switch(tagged<object>(obj).type())
14 alien *ptr = untag<alien>(obj);
15 if(to_boolean(ptr->expired))
16 general_error(ERROR_EXPIRED,obj,false_object,NULL);
17 if(to_boolean(ptr->base))
18 type_error(ALIEN_TYPE,obj);
20 return (char *)ptr->address;
25 type_error(ALIEN_TYPE,obj);
26 return NULL; /* can't happen */
31 cell factor_vm::allot_alien(cell delegate_, cell displacement)
33 data_root<object> delegate(delegate_,this);
34 data_root<alien> new_alien(allot<alien>(sizeof(alien)),this);
36 if(delegate.type_p(ALIEN_TYPE))
38 tagged<alien> delegate_alien = delegate.as<alien>();
39 displacement += delegate_alien->displacement;
40 new_alien->base = delegate_alien->base;
43 new_alien->base = delegate.value();
45 new_alien->displacement = displacement;
46 new_alien->expired = false_object;
47 new_alien->update_address();
49 return new_alien.value();
52 /* make an alien pointing at an offset of another alien */
53 void factor_vm::primitive_displaced_alien()
56 cell displacement = to_cell(dpop());
58 if(!to_boolean(alien) && displacement == 0)
62 switch(tagged<object>(alien).type())
67 dpush(allot_alien(alien,displacement));
70 type_error(ALIEN_TYPE,alien);
76 /* address of an object representing a C pointer. Explicitly throw an error
77 if the object is a byte array, as a sanity check. */
78 void factor_vm::primitive_alien_address()
80 box_unsigned_cell((cell)pinned_alien_offset(dpop()));
83 /* pop ( alien n ) from datastack, return alien's address plus n */
84 void *factor_vm::alien_pointer()
86 fixnum offset = to_fixnum(dpop());
87 return unbox_alien() + offset;
90 /* define words to read/write values at an alien address */
91 #define DEFINE_ALIEN_ACCESSOR(name,type,boxer,to) \
92 PRIMITIVE(alien_##name) \
94 parent->boxer(*(type*)(parent->alien_pointer())); \
96 PRIMITIVE(set_alien_##name) \
98 type *ptr = (type *)parent->alien_pointer(); \
99 type value = parent->to(dpop()); \
103 DEFINE_ALIEN_ACCESSOR(signed_cell,fixnum,box_signed_cell,to_fixnum)
104 DEFINE_ALIEN_ACCESSOR(unsigned_cell,cell,box_unsigned_cell,to_cell)
105 DEFINE_ALIEN_ACCESSOR(signed_8,s64,box_signed_8,to_signed_8)
106 DEFINE_ALIEN_ACCESSOR(unsigned_8,u64,box_unsigned_8,to_unsigned_8)
107 DEFINE_ALIEN_ACCESSOR(signed_4,s32,box_signed_4,to_fixnum)
108 DEFINE_ALIEN_ACCESSOR(unsigned_4,u32,box_unsigned_4,to_cell)
109 DEFINE_ALIEN_ACCESSOR(signed_2,s16,box_signed_2,to_fixnum)
110 DEFINE_ALIEN_ACCESSOR(unsigned_2,u16,box_unsigned_2,to_cell)
111 DEFINE_ALIEN_ACCESSOR(signed_1,s8,box_signed_1,to_fixnum)
112 DEFINE_ALIEN_ACCESSOR(unsigned_1,u8,box_unsigned_1,to_cell)
113 DEFINE_ALIEN_ACCESSOR(float,float,box_float,to_float)
114 DEFINE_ALIEN_ACCESSOR(double,double,box_double,to_double)
115 DEFINE_ALIEN_ACCESSOR(cell,void *,box_alien,pinned_alien_offset)
117 /* open a native library and push a handle */
118 void factor_vm::primitive_dlopen()
120 data_root<byte_array> path(dpop(),this);
121 path.untag_check(this);
122 data_root<dll> library(allot<dll>(sizeof(dll)),this);
123 library->path = path.value();
124 ffi_dlopen(library.untagged());
125 dpush(library.value());
128 /* look up a symbol in a native library */
129 void factor_vm::primitive_dlsym()
131 data_root<object> library(dpop(),this);
132 data_root<byte_array> name(dpop(),this);
133 name.untag_check(this);
135 symbol_char *sym = name->data<symbol_char>();
137 if(to_boolean(library.value()))
139 dll *d = untag_check<dll>(library.value());
144 box_alien(ffi_dlsym(d,sym));
147 box_alien(ffi_dlsym(NULL,sym));
150 /* close a native library handle */
151 void factor_vm::primitive_dlclose()
153 dll *d = untag_check<dll>(dpop());
158 void factor_vm::primitive_dll_validp()
160 cell library = dpop();
161 if(to_boolean(library))
162 dpush(tag_boolean(untag_check<dll>(library)->dll != NULL));
167 /* gets the address of an object representing a C pointer */
168 char *factor_vm::alien_offset(cell obj)
170 switch(tagged<object>(obj).type())
172 case BYTE_ARRAY_TYPE:
173 return untag<byte_array>(obj)->data<char>();
175 return (char *)untag<alien>(obj)->address;
179 type_error(ALIEN_TYPE,obj);
180 return NULL; /* can't happen */
184 VM_C_API char *alien_offset(cell obj, factor_vm *parent)
186 return parent->alien_offset(obj);
189 /* pop an object representing a C pointer */
190 char *factor_vm::unbox_alien()
192 return alien_offset(dpop());
195 VM_C_API char *unbox_alien(factor_vm *parent)
197 return parent->unbox_alien();
200 /* make an alien and push */
201 void factor_vm::box_alien(void *ptr)
206 dpush(allot_alien(false_object,(cell)ptr));
209 VM_C_API void box_alien(void *ptr, factor_vm *parent)
211 return parent->box_alien(ptr);
214 /* for FFI calls passing structs by value */
215 void factor_vm::to_value_struct(cell src, void *dest, cell size)
217 memcpy(dest,alien_offset(src),size);
220 VM_C_API void to_value_struct(cell src, void *dest, cell size, factor_vm *parent)
222 return parent->to_value_struct(src,dest,size);
225 /* for FFI callbacks receiving structs by value */
226 void factor_vm::box_value_struct(void *src, cell size)
228 byte_array *bytes = allot_byte_array(size);
229 memcpy(bytes->data<void>(),src,size);
230 dpush(tag<byte_array>(bytes));
233 VM_C_API void box_value_struct(void *src, cell size,factor_vm *parent)
235 return parent->box_value_struct(src,size);
238 /* On some x86 OSes, structs <= 8 bytes are returned in registers. */
239 void factor_vm::box_small_struct(cell x, cell y, cell size)
244 box_value_struct(data,size);
247 VM_C_API void box_small_struct(cell x, cell y, cell size, factor_vm *parent)
249 return parent->box_small_struct(x,y,size);
252 /* On OS X/PPC, complex numbers are returned in registers. */
253 void factor_vm::box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
260 box_value_struct(data,size);
263 VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factor_vm *parent)
265 return parent->box_medium_struct(x1, x2, x3, x4, size);
268 void factor_vm::primitive_vm_ptr()