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 */
30 VM_C_API char *pinned_alien_offset(cell obj, factor_vm *parent)
32 return parent->pinned_alien_offset(obj);
36 cell factor_vm::allot_alien(cell delegate_, cell displacement)
38 if(delegate_ == false_object && displacement == 0)
41 data_root<object> delegate(delegate_,this);
42 data_root<alien> new_alien(allot<alien>(sizeof(alien)),this);
44 if(delegate.type_p(ALIEN_TYPE))
46 tagged<alien> delegate_alien = delegate.as<alien>();
47 displacement += delegate_alien->displacement;
48 new_alien->base = delegate_alien->base;
51 new_alien->base = delegate.value();
53 new_alien->displacement = displacement;
54 new_alien->expired = false_object;
55 new_alien->update_address();
57 return new_alien.value();
60 cell factor_vm::allot_alien(void *address)
62 return allot_alien(false_object,(cell)address);
65 VM_C_API cell allot_alien(void *address, factor_vm *vm)
67 return vm->allot_alien(address);
70 /* make an alien pointing at an offset of another alien */
71 void factor_vm::primitive_displaced_alien()
73 cell alien = ctx->pop();
74 cell displacement = to_cell(ctx->pop());
76 switch(tagged<object>(alien).type())
81 ctx->push(allot_alien(alien,displacement));
84 type_error(ALIEN_TYPE,alien);
89 /* address of an object representing a C pointer. Explicitly throw an error
90 if the object is a byte array, as a sanity check. */
91 void factor_vm::primitive_alien_address()
93 ctx->push(allot_cell((cell)pinned_alien_offset(ctx->pop())));
96 /* pop ( alien n ) from datastack, return alien's address plus n */
97 void *factor_vm::alien_pointer()
99 fixnum offset = to_fixnum(ctx->pop());
100 return alien_offset(ctx->pop()) + offset;
103 /* define words to read/write values at an alien address */
104 #define DEFINE_ALIEN_ACCESSOR(name,type,from,to) \
105 PRIMITIVE(alien_##name) \
107 parent->ctx->push(from(*(type*)(parent->alien_pointer()),parent)); \
109 PRIMITIVE(set_alien_##name) \
111 type *ptr = (type *)parent->alien_pointer(); \
112 type value = to(parent->ctx->pop(),parent); \
116 DEFINE_ALIEN_ACCESSOR(signed_cell,fixnum,from_signed_cell,to_fixnum)
117 DEFINE_ALIEN_ACCESSOR(unsigned_cell,cell,from_unsigned_cell,to_cell)
118 DEFINE_ALIEN_ACCESSOR(signed_8,s64,from_signed_8,to_signed_8)
119 DEFINE_ALIEN_ACCESSOR(unsigned_8,u64,from_unsigned_8,to_unsigned_8)
120 DEFINE_ALIEN_ACCESSOR(signed_4,s32,from_signed_4,to_fixnum)
121 DEFINE_ALIEN_ACCESSOR(unsigned_4,u32,from_unsigned_4,to_cell)
122 DEFINE_ALIEN_ACCESSOR(signed_2,s16,from_signed_2,to_fixnum)
123 DEFINE_ALIEN_ACCESSOR(unsigned_2,u16,from_unsigned_2,to_cell)
124 DEFINE_ALIEN_ACCESSOR(signed_1,s8,from_signed_1,to_fixnum)
125 DEFINE_ALIEN_ACCESSOR(unsigned_1,u8,from_unsigned_1,to_cell)
126 DEFINE_ALIEN_ACCESSOR(float,float,from_float,to_float)
127 DEFINE_ALIEN_ACCESSOR(double,double,from_double,to_double)
128 DEFINE_ALIEN_ACCESSOR(cell,void *,allot_alien,pinned_alien_offset)
130 /* open a native library and push a handle */
131 void factor_vm::primitive_dlopen()
133 data_root<byte_array> path(ctx->pop(),this);
134 path.untag_check(this);
135 data_root<dll> library(allot<dll>(sizeof(dll)),this);
136 library->path = path.value();
137 ffi_dlopen(library.untagged());
138 ctx->push(library.value());
141 /* look up a symbol in a native library */
142 void factor_vm::primitive_dlsym()
144 data_root<object> library(ctx->pop(),this);
145 data_root<byte_array> name(ctx->pop(),this);
146 name.untag_check(this);
148 symbol_char *sym = name->data<symbol_char>();
150 if(to_boolean(library.value()))
152 dll *d = untag_check<dll>(library.value());
155 ctx->push(false_object);
157 ctx->push(allot_alien(ffi_dlsym(d,sym)));
160 ctx->push(allot_alien(ffi_dlsym(NULL,sym)));
163 /* close a native library handle */
164 void factor_vm::primitive_dlclose()
166 dll *d = untag_check<dll>(ctx->pop());
171 void factor_vm::primitive_dll_validp()
173 cell library = ctx->pop();
174 if(to_boolean(library))
175 ctx->push(tag_boolean(untag_check<dll>(library)->dll != NULL));
177 ctx->push(true_object);
180 /* gets the address of an object representing a C pointer */
181 char *factor_vm::alien_offset(cell obj)
183 switch(tagged<object>(obj).type())
185 case BYTE_ARRAY_TYPE:
186 return untag<byte_array>(obj)->data<char>();
188 return (char *)untag<alien>(obj)->address;
192 type_error(ALIEN_TYPE,obj);
193 return NULL; /* can't happen */
197 VM_C_API char *alien_offset(cell obj, factor_vm *parent)
199 return parent->alien_offset(obj);
202 /* For FFI calls passing structs by value. Cannot allocate */
203 void factor_vm::to_value_struct(cell src, void *dest, cell size)
205 memcpy(dest,alien_offset(src),size);
208 VM_C_API void to_value_struct(cell src, void *dest, cell size, factor_vm *parent)
210 return parent->to_value_struct(src,dest,size);
213 /* For FFI callbacks receiving structs by value */
214 cell factor_vm::from_value_struct(void *src, cell size)
216 byte_array *bytes = allot_byte_array(size);
217 memcpy(bytes->data<void>(),src,size);
218 return tag<byte_array>(bytes);
221 VM_C_API cell from_value_struct(void *src, cell size, factor_vm *parent)
223 return parent->from_value_struct(src,size);
226 /* On some x86 OSes, structs <= 8 bytes are returned in registers. */
227 cell factor_vm::from_small_struct(cell x, cell y, cell size)
232 return from_value_struct(data,size);
235 VM_C_API cell from_small_struct(cell x, cell y, cell size, factor_vm *parent)
237 return parent->from_small_struct(x,y,size);
240 /* On OS X/PPC, complex numbers are returned in registers. */
241 cell factor_vm::from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
248 return from_value_struct(data,size);
251 VM_C_API cell from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factor_vm *parent)
253 return parent->from_medium_struct(x1, x2, x3, x4, size);
256 void factor_vm::primitive_vm_ptr()
258 ctx->push(allot_alien(this));