inline mword *get_from_udr_stack(bvm_cache *this_bvm, mword *stack_ptr, mword stack_index){ // get_from_udr_stack# // return _chain_deref( this_bvm->sym_table, (mword*)icar( _ith( (mword*)icar( stack_ptr ), stack_index )) ); // return (mword*)icar( _ith( (mword*)icar( stack_ptr ), stack_index )); return _chain_deref( this_bvm, (mword*)icar( _ith( (mword*)icar( stack_ptr ), stack_index )) ); }
bvm_cache *bvm_new(bvm_cache *this_bvm){ // bvm_new# #ifdef BABEL_RESET_TRACE _trace; #endif mword *self = tptr_detag(this_bvm, tptr_detag(this_bvm, this_bvm->self)); lci(bvm_dstack_ptr(this_bvm),0) = stack_new(this_bvm); #define Y(a,b,c) \ if(!_exha(this_bvm, self, c)){ \ _insha( this_bvm, \ self, \ c, \ nil, \ hash_new_entry( \ this_bvm, \ c, \ nil, \ nil)); \ } #define X(a,b,c) \ if(!trie_exists(this_bvm, self, c, nil)){ \ trie_insert(this_bvm, self, c, nil, nil); \ } CACHED_FIELDS #undef X mword *local_root = _ith( this_bvm, trie_lookup_hash(this_bvm, self, BABEL_SYM_LOCAL_ROOT, nil), 2 ); if(is_nil(local_root)){ trie_insert(this_bvm, self, BABEL_SYM_LOCAL_ROOT, nil, _ith( this_bvm, trie_lookup_hash(this_bvm, self, BABEL_SYM_SOFT_ROOT, nil), 2)); } cache_update(this_bvm); this_bvm->flags->BVM_CACHE_DIRTY = FLAG_CLR; this_bvm->flags->BVM_CACHE_INVALID = FLAG_CLR; return this_bvm; }
inline mword *set_in_udr_stack(bvm_cache *this_bvm, mword *stack_ptr, mword stack_index, mword *bs){ // set_in_udr_stack# // mword *stack_entry = _chain_deref( this_bvm->sym_table, (mword*)icar( icar( _ith( stack_ptr, stack_index ))) ); mword *stack_entry = (mword*)icar( icar( _ith( stack_ptr, stack_index ))); (mword*)c(stack_entry,0) = bs; return stack_entry; }
void bpdl_init_opcode_table(bvm_cache *this_bvm){ // bpdl_init_opcode_table# #if(defined BPDL_TRACE || defined BABEL_RESET_TRACE) _trace; #endif this_bvm->flags->MC_USE_MALLOC = FLAG_SET; mword *opcode_table = _slurp(this_bvm, C2B("src/opcode_table.bbl")); bpdl_opcode_table = _load(this_bvm, opcode_table, size(opcode_table)); this_bvm->flags->MC_USE_MALLOC = FLAG_CLR; bpdl_return_opcode = _ith(this_bvm, trie_lookup_hash(this_bvm, bpdl_opcode_table, HASH8(this_bvm, "return"), nil), 2); }
mword *inline_bpdl_label_list(bvm_cache *this_bvm, mword *sexpr){ // inline_bpdl_label_list# mword *sexpr_label = (mword*)icar(sexpr); if(bpdl_is_label_nil(sexpr_label)){ return nil; } mword *macro_code_list; mword *bpdl_list; mword *result = nil; mword *bpdl_label = _lf2by(this_bvm, sexpr_label); mword *bpdl_label_hash = _hash8(this_bvm,bpdl_label); if(trie_exists(this_bvm, bpdl_macro_table, bpdl_label_hash, nil)){ bpdl_list = inline_bpdl_list_list(this_bvm, (mword *)icdr(sexpr)); macro_code_list = _cons( this_bvm, _cp( this_bvm, _ith( this_bvm, trie_lookup_hash(this_bvm, bpdl_macro_table, bpdl_label_hash, nil), 2) ), nil); // result = lib_babelc(this_bvm, (mword*)icar(macro_code_list), bpdl_list); result = lib_babelcs(this_bvm, (mword*)icar(macro_code_list), bpdl_list, this_bvm->soft_root); } else{ _fatal("Unrecognized label-list"); //FIXME Throw exception } return result; }
mword *_babel(bvm_cache *this_bvm, mword *loaded_bvm, mword *arg_stack, mword *sym_table){ // _babel# bvm_cache new_bvm; bvm_cache *new_bvm_ptr = &new_bvm; mword *result = nil; cache_new(this_bvm, new_bvm_ptr, loaded_bvm); mword *self = tptr_detag(new_bvm_ptr, tptr_detag(new_bvm_ptr, new_bvm_ptr->self)); // Could blow up due to mem_alloc() if( !trie_exists(new_bvm_ptr, self, BABEL_SYM_BVM_INITD, nil) ){ trie_insert( new_bvm_ptr, self, BABEL_SYM_BVM_INITD, nil, _val(new_bvm_ptr,1) ); // trie_insert( new_bvm_ptr, self, BABEL_SYM_BVM_INITD, nil, _val(new_bvm_ptr,0) ); } mword *bvm_initd = rci(cache_read_from_bvm(new_bvm_ptr, BABEL_SYM_BVM_INITD),0); if(!rcl(bvm_initd,0)){ bvm_new(new_bvm_ptr); lcl(bvm_initd,0) = 1; } else{ cache_update(new_bvm_ptr); } if( !trie_exists(new_bvm_ptr, self, BABEL_SYM_CODE_RESTART_POINT, nil) ){ trie_insert( new_bvm_ptr, self, BABEL_SYM_CODE_RESTART_POINT, nil, rci(new_bvm_ptr->code_ptr,0)); } new_bvm_ptr->flags->BVM_CACHE_DIRTY = FLAG_CLR; new_bvm_ptr->flags->BVM_CACHE_INVALID = FLAG_CLR; cache_flush(this_bvm); if(!is_nil(sym_table)){ trie_insert(new_bvm_ptr, tptr_detag(new_bvm_ptr, new_bvm_ptr->self), BABEL_SYM_SOFT_ROOT, nil, sym_table); } trie_insert(new_bvm_ptr, tptr_detag(new_bvm_ptr, new_bvm_ptr->self), BABEL_SYM_PARENT_BVM, nil, this_bvm->self); new_bvm_ptr->flags->BVM_CODE_LIST_EMPTY = FLAG_CLR; while(!is_nil(arg_stack)){ // give the arg-list onto the BVM's dstack interp_push_operand(new_bvm_ptr, rci(arg_stack, 0)); arg_stack = rci(arg_stack,1); } interp_core(new_bvm_ptr); cache_cp(new_bvm_ptr, this_bvm); //update flags and interp this_bvm->self = _ith( this_bvm, trie_lookup_hash( new_bvm_ptr, tptr_detag(new_bvm_ptr, new_bvm_ptr->self), BABEL_SYM_PARENT_BVM, nil), 2 ); cache_update(this_bvm); this_bvm->flags->BVM_CACHE_DIRTY = FLAG_CLR; this_bvm->flags->BVM_CACHE_INVALID = FLAG_CLR; //copy TOS from new_bvm to this_bvm oinfo oi; oi.default_data = nil; oi.required_tag = nil; oi.mask = OI_MASK_ANY; oi.min_size = 0; oi.max_size = 1; if( new_bvm_ptr->flags->BVM_RETURN_TOS_ON_EXIT == FLAG_SET && (new_bvm_ptr->flags->BVM_CODE_LIST_EMPTY == FLAG_SET || (get_advance_type(new_bvm_ptr) == BVM_RETURN))){ get_operands(new_bvm_ptr,1,&oi); result = oi.data; stack_pop(new_bvm_ptr,rci(new_bvm_ptr->dstack_ptr,0)); // stack_push(this_bvm, // rci(this_bvm->dstack_ptr,0), // stack_new_entry( // this_bvm, // oi.data, // nil)); } // Reset all flags in case of re-entry new_bvm_ptr->flags->BVM_RETURN_TOS_ON_EXIT = FLAG_CLR; // FIXME: This restore to previous value, not force-clear new_bvm_ptr->flags->BVM_CODE_LIST_EMPTY = FLAG_CLR; if(get_advance_type(new_bvm_ptr) == BVM_RETURN){ set_advance_type(new_bvm_ptr, BVM_ADVANCE); } this_bvm->flags->BVM_RETURN_TOS_ON_EXIT = FLAG_CLR; this_bvm->flags->BVM_CODE_LIST_EMPTY = FLAG_CLR; return result; }
mword *inline_bpdl_code_list(bvm_cache *this_bvm, mword *sexpr){ // inline_bpdl_code_list# #ifdef BPDL_TRACE _trace; #endif // 1. string // 2. number // 3. built-in (opcodes) // 3. label (lookup in sym-table) // 4. recurse inline_bpdl mword entry_type; mword *list_head = nil; mword *list_curr = nil; mword *new_entry; mword *bpdl_label; mword *bpdl_label_hash; while(!is_nil(sexpr)){ entry_type = get_bpdl_list_entry_type((mword*)icar(sexpr)); switch(entry_type){ case BPDL_LIST_ENTRY_DNUMBER: case BPDL_LIST_ENTRY_HNUMBER: case BPDL_LIST_ENTRY_DQUOTE: case BPDL_LIST_ENTRY_SQUOTE: new_entry = _cons( this_bvm, _cons( this_bvm, bpdl_const_to_bstruct( this_bvm, (mword*)icar(sexpr), entry_type), nil), nil); if(is_nil(list_head)){ list_head = list_curr = new_entry; } else{ _append_direct(this_bvm, list_curr, new_entry); list_curr = (mword*)icdr(list_curr); // Save unnecessary traversal } break; case BPDL_LIST_ENTRY_LABEL: if(_arcmp((mword*)icar(sexpr), SEXPR_NIL_SYMBOL) == 0){ new_entry = _cons( this_bvm, _cons( this_bvm, nil, nil), nil); } else{ // if built-in: // substitute opcode-value bpdl_label = _lf2by(this_bvm, (mword*)icar(sexpr)); bpdl_label_hash = _hash8(this_bvm,bpdl_label); if(trie_exists(this_bvm, bpdl_opcode_table, bpdl_label_hash, nil)){ new_entry = _cons( this_bvm, _cp( this_bvm, _ith( this_bvm, trie_lookup_hash(this_bvm, bpdl_opcode_table, bpdl_label_hash, nil), 2) ), nil); } else{ new_entry = _cons( this_bvm, tptr_new(this_bvm, bpdl_label_hash, nil), nil); } } if(is_nil(list_head)){ list_head = list_curr = new_entry; } else{ _append_direct(this_bvm, list_curr, new_entry); list_curr = (mword*)icdr(list_curr); // Save unnecessary traversal } break; case BPDL_LIST_ENTRY_INTE: new_entry = _cons( this_bvm, _cons( this_bvm, inline_bpdl(this_bvm, (mword*)icar(sexpr)), nil), nil); if(is_nil(list_head)){ list_head = list_curr = new_entry; } else{ _append_direct(this_bvm, list_curr, new_entry); list_curr = (mword*)icdr(list_curr); // Save unnecessary traversal } break; default: _d(entry_type); _fatal("Unrecognized bpdl list entry"); //FIXME Throw exception } sexpr = (mword*)icdr(sexpr); } return list_head; }