mword *tptr_find_tag(bvm_cache *this_bvm, mword *search_bs, mword *tag){ // tptr_find_tag#
if(is_nil(search_bs) || is_nil(tag)){
return nil;
}
mword *search_tag;
if(is_tptr(tag)){
search_tag = tag;
}
else{
search_tag = tptr_new(this_bvm, tag, nil);
}
mword *sub_list = bstruct_find(this_bvm, search_bs, search_tag);
mword *result = nil;
while(!is_nil(sub_list)){
result = _cons(this_bvm, rci(rci(sub_list,0),0), result);
sub_list = (mword*)icdr(sub_list);
}
return result;
}
mword *tptr_extract_ptr(bvm_cache *this_bvm, mword *tptr){ // tptr_extract_ptr#
mword* temp = (mword*)(tptr+TPTR_PTR_OFFSET);
if(is_tptr(temp)){
return tptr_extract_ptr(this_bvm, temp);
}
else{
return temp;
}
}
// Hard de-references a tag (recursive)
//
mword *tptr_hard_detag(bvm_cache *this_bvm, mword *tptr){ // tptr_hard_detag#
mword *temp = get_tptr(tptr);
if(is_tptr(temp)){
return tptr_hard_detag(this_bvm, temp);
}
else{
return temp;
}
}
// Safely, recursively de-references a tag
mword *tptr_detag(bvm_cache *this_bvm, mword *tptr){ // tptr_detag#
static int livelock_detect=0;
if(is_nil(tptr)){
return nil;
}
if(is_tptr(tptr)){
if(livelock_detect++ > MAX_DETAG_DEPTH){
//cat_except(this_bvm);
_fatal("FIXME: this should have been a cat_except...");
}
return tptr_detag(this_bvm, get_tptr(tptr));
}
else{
livelock_detect=0;
return tptr;
}
}
// same as pop_udr_stack except calls mc_free if PACMAN tag
//
void zap_udr_stack(mword *stack_ptr){ // zap_udr_stack#
mword *free_ptr = (mword*)icar(stack_ptr);
mword *tag = (mword*)icar(icdr(icar(icar(stack_ptr))));
mword *temp = (mword*)icar(icar(icar(stack_ptr)));
(mword*)*stack_ptr = _pop((mword*)icar(stack_ptr));
//_dump(stack_ptr);
// trace;
// _mem(temp);
// printf("\n");
if(is_tptr(tag) && tageq(tag,BABEL_TAG_PACMAN,TAG_SIZE)){
//printf("MATCH\n");
mc_free(temp);
}
free_lumbar(free_ptr);
}
// XXX The return-value from this function contains unsafe pointers!!! XXX
// XXX internal interp use ONLY XXX
// XXX If you pass tag=nil, returns ALL tags in bs XXX
// XXX PERF: A _tags2ar (like _bs2ar) would be more efficient XXX
//
mword *tptr_find_tag_unsafe(bvm_cache *this_bvm, mword *bs, mword *tag){ // tptr_find_tag_unsafe#
mword *span_array = _bs2ar(this_bvm, bs);
mword size_span_array = size(span_array);
mword size_inte;
mword *tag_list = nil;
mword *curr_span_elem;
mword *curr_inte_elem;
//_dump(span_array);
int i,j;
for(i=0; i<size_span_array; i++){
curr_span_elem = rci(span_array,i);
if(is_inte(curr_span_elem)){ // check each element
size_inte = size(curr_span_elem);
for(j=0;j<size_inte;j++){
curr_inte_elem = rci(curr_span_elem,j);
if(is_nil(curr_inte_elem)){
continue;
}
if(is_tptr(curr_inte_elem)){
if(is_nil(tag)){
// push onto tag_list
if(is_nil(tag_list)){
tag_list = _cons(this_bvm, (curr_span_elem+j), nil);
}
else{
_unshift(this_bvm, tag_list, (curr_span_elem+j));
}
}
else{
if( tageq(curr_inte_elem, tag, TAG_SIZE) ){
// push onto tag_list
if(is_nil(tag_list)){
tag_list = _cons(this_bvm, (curr_span_elem+j), nil);
}
else{
_unshift(this_bvm, tag_list, (curr_span_elem+j));
}
}
}
}
}
}
}
return tag_list;
}
