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 *factorvm::pinned_alien_offset(cell obj)
10 switch(tagged<object>(obj).type())
14 alien *ptr = untag<alien>(obj);
16 general_error(ERROR_EXPIRED,obj,F,NULL);
17 return pinned_alien_offset(ptr->alien) + ptr->displacement;
22 type_error(ALIEN_TYPE,obj);
23 return NULL; /* can't happen */
28 cell factorvm::allot_alien(cell delegate_, cell displacement)
30 gc_root<object> delegate(delegate_,this);
31 gc_root<alien> new_alien(allot<alien>(sizeof(alien)),this);
33 if(delegate.type_p(ALIEN_TYPE))
35 tagged<alien> delegate_alien = delegate.as<alien>();
36 displacement += delegate_alien->displacement;
37 new_alien->alien = delegate_alien->alien;
40 new_alien->alien = delegate.value();
42 new_alien->displacement = displacement;
43 new_alien->expired = F;
45 return new_alien.value();
48 /* make an alien pointing at an offset of another alien */
49 inline void factorvm::vmprim_displaced_alien()
52 cell displacement = to_cell(dpop());
54 if(alien == F && displacement == 0)
58 switch(tagged<object>(alien).type())
63 dpush(allot_alien(alien,displacement));
66 type_error(ALIEN_TYPE,alien);
72 PRIMITIVE(displaced_alien)
74 PRIMITIVE_GETVM()->vmprim_displaced_alien();
77 /* address of an object representing a C pointer. Explicitly throw an error
78 if the object is a byte array, as a sanity check. */
79 inline void factorvm::vmprim_alien_address()
81 box_unsigned_cell((cell)pinned_alien_offset(dpop()));
84 PRIMITIVE(alien_address)
86 PRIMITIVE_GETVM()->vmprim_alien_address();
89 /* pop ( alien n ) from datastack, return alien's address plus n */
90 void *factorvm::alien_pointer()
92 fixnum offset = to_fixnum(dpop());
93 return unbox_alien() + offset;
98 return vm->alien_pointer();
102 /* define words to read/write values at an alien address */
103 #define DEFINE_ALIEN_ACCESSOR(name,type,boxer,to) \
104 PRIMITIVE(alien_##name) \
106 PRIMITIVE_GETVM()->boxer(*(type*)PRIMITIVE_GETVM()->alien_pointer()); \
108 PRIMITIVE(set_alien_##name) \
110 type *ptr = (type *)PRIMITIVE_GETVM()->alien_pointer(); \
111 type value = PRIMITIVE_GETVM()->to(dpop()); \
115 DEFINE_ALIEN_ACCESSOR(signed_cell,fixnum,box_signed_cell,to_fixnum)
116 DEFINE_ALIEN_ACCESSOR(unsigned_cell,cell,box_unsigned_cell,to_cell)
117 DEFINE_ALIEN_ACCESSOR(signed_8,s64,box_signed_8,to_signed_8)
118 DEFINE_ALIEN_ACCESSOR(unsigned_8,u64,box_unsigned_8,to_unsigned_8)
119 DEFINE_ALIEN_ACCESSOR(signed_4,s32,box_signed_4,to_fixnum)
120 DEFINE_ALIEN_ACCESSOR(unsigned_4,u32,box_unsigned_4,to_cell)
121 DEFINE_ALIEN_ACCESSOR(signed_2,s16,box_signed_2,to_fixnum)
122 DEFINE_ALIEN_ACCESSOR(unsigned_2,u16,box_unsigned_2,to_cell)
123 DEFINE_ALIEN_ACCESSOR(signed_1,s8,box_signed_1,to_fixnum)
124 DEFINE_ALIEN_ACCESSOR(unsigned_1,u8,box_unsigned_1,to_cell)
125 DEFINE_ALIEN_ACCESSOR(float,float,box_float,to_float)
126 DEFINE_ALIEN_ACCESSOR(double,double,box_double,to_double)
127 DEFINE_ALIEN_ACCESSOR(cell,void *,box_alien,pinned_alien_offset)
129 /* open a native library and push a handle */
130 inline void factorvm::vmprim_dlopen()
132 gc_root<byte_array> path(dpop(),this);
133 path.untag_check(this);
134 gc_root<dll> library(allot<dll>(sizeof(dll)),this);
135 library->path = path.value();
136 ffi_dlopen(library.untagged());
137 dpush(library.value());
142 PRIMITIVE_GETVM()->vmprim_dlopen();
145 /* look up a symbol in a native library */
146 inline void factorvm::vmprim_dlsym()
148 gc_root<object> library(dpop(),this);
149 gc_root<byte_array> name(dpop(),this);
150 name.untag_check(this);
152 symbol_char *sym = name->data<symbol_char>();
154 if(library.value() == F)
155 box_alien(ffi_dlsym(NULL,sym));
158 dll *d = untag_check<dll>(library.value());
163 box_alien(ffi_dlsym(d,sym));
169 PRIMITIVE_GETVM()->vmprim_dlsym();
172 /* close a native library handle */
173 inline void factorvm::vmprim_dlclose()
175 dll *d = untag_check<dll>(dpop());
182 PRIMITIVE_GETVM()->vmprim_dlclose();
185 inline void factorvm::vmprim_dll_validp()
187 cell library = dpop();
191 dpush(untag_check<dll>(library)->dll == NULL ? F : T);
194 PRIMITIVE(dll_validp)
196 PRIMITIVE_GETVM()->vmprim_dll_validp();
199 /* gets the address of an object representing a C pointer */
200 char *factorvm::alien_offset(cell obj)
202 switch(tagged<object>(obj).type())
204 case BYTE_ARRAY_TYPE:
205 return untag<byte_array>(obj)->data<char>();
208 alien *ptr = untag<alien>(obj);
209 if(ptr->expired != F)
210 general_error(ERROR_EXPIRED,obj,F,NULL);
211 return alien_offset(ptr->alien) + ptr->displacement;
216 type_error(ALIEN_TYPE,obj);
217 return NULL; /* can't happen */
221 VM_C_API char *alien_offset(cell obj, factorvm *myvm)
224 return VM_PTR->alien_offset(obj);
227 /* pop an object representing a C pointer */
228 char *factorvm::unbox_alien()
230 return alien_offset(dpop());
233 VM_C_API char *unbox_alien()
235 printf("*PHIL unbox_alien\n");fflush(stdout);
236 return vm->unbox_alien();
239 /* make an alien and push */
240 void factorvm::box_alien(void *ptr)
245 dpush(allot_alien(F,(cell)ptr));
248 VM_C_API void box_alien(void *ptr, factorvm *myvm)
251 return VM_PTR->box_alien(ptr);
254 /* for FFI calls passing structs by value */
255 void factorvm::to_value_struct(cell src, void *dest, cell size)
257 memcpy(dest,alien_offset(src),size);
260 VM_C_API void to_value_struct(cell src, void *dest, cell size)
262 printf("PHIL to_value_struct\n");
263 return vm->to_value_struct(src,dest,size);
266 /* for FFI callbacks receiving structs by value */
267 void factorvm::box_value_struct(void *src, cell size)
269 byte_array *bytes = allot_byte_array(size);
270 memcpy(bytes->data<void>(),src,size);
271 dpush(tag<byte_array>(bytes));
274 VM_C_API void box_value_struct(void *src, cell size)
276 printf("PHIL box_value_struct\n");
277 return vm->box_value_struct(src,size);
280 /* On some x86 OSes, structs <= 8 bytes are returned in registers. */
281 void factorvm::box_small_struct(cell x, cell y, cell size)
286 box_value_struct(data,size);
289 VM_C_API void box_small_struct(cell x, cell y, cell size)
291 printf("PHIL box_small_struct\n");
292 return vm->box_small_struct(x,y,size);
295 /* On OS X/PPC, complex numbers are returned in registers. */
296 void factorvm::box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
303 box_value_struct(data,size);
306 VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
308 printf("PHIL box_medium_struct\n");
309 return vm->box_medium_struct(x1, x2, x3, x4, size);