steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

VM: Refactor alien.cpp to Factor style

db4
Erik Charlebois 2013-05-11 21:40:43 -04:00
parent 6c919e7d72
commit 22014f092e
1 changed files with 117 additions and 142 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

259
vm/alien.cpp
View File

@ -1,203 +1,178 @@
#include "master.hpp" #include "master.hpp"
namespace factor namespace factor {
{
/* gets the address of an object representing a C pointer, with the /* gets the address of an object representing a C pointer, with the
intention of storing the pointer across code which may potentially GC. */ intention of storing the pointer across code which may potentially GC. */
char *factor_vm::pinned_alien_offset(cell obj) char* factor_vm::pinned_alien_offset(cell obj) {
{ switch (tagged<object>(obj).type()) {
switch(tagged<object>(obj).type()) case ALIEN_TYPE: {
{ alien* ptr = untag<alien>(obj);
case ALIEN_TYPE: if (to_boolean(ptr->expired))
{ general_error(ERROR_EXPIRED, obj, false_object);
alien *ptr = untag<alien>(obj); if (to_boolean(ptr->base))
if(to_boolean(ptr->expired)) type_error(ALIEN_TYPE, obj);
general_error(ERROR_EXPIRED,obj,false_object); else
if(to_boolean(ptr->base)) return (char*)ptr->address;
type_error(ALIEN_TYPE,obj); }
else case F_TYPE:
return (char *)ptr->address; return NULL;
} default:
case F_TYPE: type_error(ALIEN_TYPE, obj);
return NULL; return NULL; /* can't happen */
default: }
type_error(ALIEN_TYPE,obj);
return NULL; /* can't happen */
}
} }
/* make an alien */ /* make an alien */
/* Allocates memory */ /* Allocates memory */
cell factor_vm::allot_alien(cell delegate_, cell displacement) cell factor_vm::allot_alien(cell delegate_, cell displacement) {
{ if (displacement == 0)
if(displacement == 0) return delegate_;
return delegate_;
data_root<object> delegate(delegate_,this); data_root<object> delegate(delegate_, this);
data_root<alien> new_alien(allot<alien>(sizeof(alien)),this); data_root<alien> new_alien(allot<alien>(sizeof(alien)), this);
if(delegate.type_p(ALIEN_TYPE)) if (delegate.type_p(ALIEN_TYPE)) {
{ tagged<alien> delegate_alien = delegate.as<alien>();
tagged<alien> delegate_alien = delegate.as<alien>(); displacement += delegate_alien->displacement;
displacement += delegate_alien->displacement; new_alien->base = delegate_alien->base;
new_alien->base = delegate_alien->base; } else
} new_alien->base = delegate.value();
else
new_alien->base = delegate.value();
new_alien->displacement = displacement; new_alien->displacement = displacement;
new_alien->expired = false_object; new_alien->expired = false_object;
new_alien->update_address(); new_alien->update_address();
return new_alien.value(); return new_alien.value();
} }
/* Allocates memory */ /* Allocates memory */
cell factor_vm::allot_alien(void *address) cell factor_vm::allot_alien(void* address) {
{ return allot_alien(false_object, (cell) address);
return allot_alien(false_object,(cell)address);
} }
/* make an alien pointing at an offset of another alien */ /* make an alien pointing at an offset of another alien */
/* Allocates memory */ /* Allocates memory */
void factor_vm::primitive_displaced_alien() void factor_vm::primitive_displaced_alien() {
{ cell alien = ctx->pop();
cell alien = ctx->pop(); cell displacement = to_cell(ctx->pop());
cell displacement = to_cell(ctx->pop());
switch(tagged<object>(alien).type()) switch (tagged<object>(alien).type()) {
{ case BYTE_ARRAY_TYPE:
case BYTE_ARRAY_TYPE: case ALIEN_TYPE:
case ALIEN_TYPE: case F_TYPE:
case F_TYPE: ctx->push(allot_alien(alien, displacement));
ctx->push(allot_alien(alien,displacement)); break;
break; default:
default: type_error(ALIEN_TYPE, alien);
type_error(ALIEN_TYPE,alien); break;
break; }
}
} }
/* address of an object representing a C pointer. Explicitly throw an error /* address of an object representing a C pointer. Explicitly throw an error
if the object is a byte array, as a sanity check. */ if the object is a byte array, as a sanity check. */
/* Allocates memory (from_unsigned_cell can allocate) */ /* Allocates memory (from_unsigned_cell can allocate) */
void factor_vm::primitive_alien_address() void factor_vm::primitive_alien_address() {
{ ctx->replace(from_unsigned_cell((cell) pinned_alien_offset(ctx->peek())));
ctx->replace(from_unsigned_cell((cell)pinned_alien_offset(ctx->peek())));
} }
/* pop ( alien n ) from datastack, return alien's address plus n */ /* pop ( alien n ) from datastack, return alien's address plus n */
void *factor_vm::alien_pointer() void* factor_vm::alien_pointer() {
{ fixnum offset = to_fixnum(ctx->pop());
fixnum offset = to_fixnum(ctx->pop()); return alien_offset(ctx->pop()) + offset;
return alien_offset(ctx->pop()) + offset;
} }
/* define words to read/write values at an alien address */ /* define words to read/write values at an alien address */
#define DEFINE_ALIEN_ACCESSOR(name,type,from,to) \ #define DEFINE_ALIEN_ACCESSOR(name, type, from, to) \
VM_C_API void primitive_alien_##name(factor_vm *parent) \ VM_C_API void primitive_alien_##name(factor_vm * parent) { \
{ \ parent->ctx->push(parent->from(*(type*)(parent->alien_pointer()))); \
parent->ctx->push(parent->from(*(type*)(parent->alien_pointer()))); \ } \
} \ VM_C_API void primitive_set_alien_##name(factor_vm * parent) { \
VM_C_API void primitive_set_alien_##name(factor_vm *parent) \ type* ptr = (type*)parent->alien_pointer(); \
{ \ type value = (type) parent->to(parent->ctx->pop()); \
type *ptr = (type *)parent->alien_pointer(); \ *ptr = value; \
type value = (type)parent->to(parent->ctx->pop()); \ }
*ptr = value; \
}
EACH_ALIEN_PRIMITIVE(DEFINE_ALIEN_ACCESSOR) EACH_ALIEN_PRIMITIVE(DEFINE_ALIEN_ACCESSOR)
/* open a native library and push a handle */ /* open a native library and push a handle */
void factor_vm::primitive_dlopen() void factor_vm::primitive_dlopen() {
{ data_root<byte_array> path(ctx->pop(), this);
data_root<byte_array> path(ctx->pop(),this); path.untag_check(this);
path.untag_check(this); data_root<dll> library(allot<dll>(sizeof(dll)), this);
data_root<dll> library(allot<dll>(sizeof(dll)),this); library->path = path.value();
library->path = path.value(); ffi_dlopen(library.untagged());
ffi_dlopen(library.untagged()); ctx->push(library.value());
ctx->push(library.value());
} }
/* look up a symbol in a native library */ /* look up a symbol in a native library */
/* Allocates memory */ /* Allocates memory */
void factor_vm::primitive_dlsym() void factor_vm::primitive_dlsym() {
{ data_root<object> library(ctx->pop(), this);
data_root<object> library(ctx->pop(),this); data_root<byte_array> name(ctx->peek(), this);
data_root<byte_array> name(ctx->peek(),this); name.untag_check(this);
name.untag_check(this);
symbol_char *sym = name->data<symbol_char>(); symbol_char* sym = name->data<symbol_char>();
if(to_boolean(library.value())) if (to_boolean(library.value())) {
{ dll* d = untag_check<dll>(library.value());
dll *d = untag_check<dll>(library.value());
if(d->handle == NULL) if (d->handle == NULL)
ctx->replace(false_object); ctx->replace(false_object);
else else
ctx->replace(allot_alien(ffi_dlsym(d,sym))); ctx->replace(allot_alien(ffi_dlsym(d, sym)));
} } else
else ctx->replace(allot_alien(ffi_dlsym(NULL, sym)));
ctx->replace(allot_alien(ffi_dlsym(NULL,sym)));
} }
/* look up a symbol in a native library */ /* look up a symbol in a native library */
/* Allocates memory */ /* Allocates memory */
void factor_vm::primitive_dlsym_raw() void factor_vm::primitive_dlsym_raw() {
{ data_root<object> library(ctx->pop(), this);
data_root<object> library(ctx->pop(),this); data_root<byte_array> name(ctx->peek(), this);
data_root<byte_array> name(ctx->peek(),this); name.untag_check(this);
name.untag_check(this);
symbol_char *sym = name->data<symbol_char>(); symbol_char* sym = name->data<symbol_char>();
if(to_boolean(library.value())) if (to_boolean(library.value())) {
{ dll* d = untag_check<dll>(library.value());
dll *d = untag_check<dll>(library.value());
if(d->handle == NULL) if (d->handle == NULL)
ctx->replace(false_object); ctx->replace(false_object);
else else
ctx->replace(allot_alien(ffi_dlsym_raw(d,sym))); ctx->replace(allot_alien(ffi_dlsym_raw(d, sym)));
} } else
else ctx->replace(allot_alien(ffi_dlsym_raw(NULL, sym)));
ctx->replace(allot_alien(ffi_dlsym_raw(NULL,sym)));
} }
/* close a native library handle */ /* close a native library handle */
void factor_vm::primitive_dlclose() void factor_vm::primitive_dlclose() {
{ dll* d = untag_check<dll>(ctx->pop());
dll *d = untag_check<dll>(ctx->pop()); if (d->handle != NULL)
if(d->handle != NULL) ffi_dlclose(d);
ffi_dlclose(d);
} }
void factor_vm::primitive_dll_validp() void factor_vm::primitive_dll_validp() {
{ cell library = ctx->peek();
cell library = ctx->peek(); if (to_boolean(library))
if(to_boolean(library)) ctx->replace(tag_boolean(untag_check<dll>(library)->handle != NULL));
ctx->replace(tag_boolean(untag_check<dll>(library)->handle != NULL)); else
else ctx->replace(true_object);
ctx->replace(true_object);
} }
/* gets the address of an object representing a C pointer */ /* gets the address of an object representing a C pointer */
char *factor_vm::alien_offset(cell obj) char* factor_vm::alien_offset(cell obj) {
{ switch (tagged<object>(obj).type()) {
switch(tagged<object>(obj).type()) case BYTE_ARRAY_TYPE:
{ return untag<byte_array>(obj)->data<char>();
case BYTE_ARRAY_TYPE: case ALIEN_TYPE:
return untag<byte_array>(obj)->data<char>(); return (char*)untag<alien>(obj)->address;
case ALIEN_TYPE: case F_TYPE:
return (char *)untag<alien>(obj)->address; return NULL;
case F_TYPE: default:
return NULL; type_error(ALIEN_TYPE, obj);
default: return NULL; /* can't happen */
type_error(ALIEN_TYPE,obj); }
return NULL; /* can't happen */
}
} }
} }