diff --git a/lib/comp.c b/lib/comp.c index 196f0d3..cccc059 100644 --- a/lib/comp.c +++ b/lib/comp.c @@ -32,6 +32,7 @@ enum VAR_INDEXED }; +#define CODE_BUFFER_ALIGN 1024 /* TODO: set a bigger value */ #define TV_BUFFER_ALIGN 256 #define BLK_TMPRCNT_BUFFER_ALIGN 128 @@ -154,27 +155,38 @@ static int store_temporary_variable_count_for_block (hcl_t* hcl, hcl_oow_t tmpr_ static HCL_INLINE void patch_instruction (hcl_t* hcl, hcl_oow_t index, hcl_oob_t bc) { HCL_ASSERT (index < hcl->code.bc.len); - ((hcl_oop_byte_t)hcl->code.bc.arr)->slot[index] = bc; + hcl->code.bc.arr->slot[index] = bc; } static int emit_byte_instruction (hcl_t* hcl, hcl_oob_t bc) { hcl_oow_t capa; + /* the context object has the ip field. it should be representable + * in a small integer. for simplicity, limit the total byte code length + * to fit in a small integer. because 'ip' points to the next instruction + * to execute, he upper bound should be (max - 1) so that i stays + * at the max when incremented */ + if (hcl->code.bc.len == HCL_SMOOI_MAX - 1) + { + hcl->errnum = HCL_EBCFULL; /* byte code full/too big */ + return -1; + } + capa = HCL_OBJ_GET_SIZE(hcl->code.bc.arr); if (hcl->code.bc.len >= capa) { hcl_oop_t tmp; hcl_oow_t newcapa; - newcapa = capa + 20000; /* TODO: set a better resizing policy */ - tmp = hcl_remakengcbytearray (hcl, hcl->code.bc.arr, newcapa); + newcapa = HCL_ALIGN (capa + 1, CODE_BUFFER_ALIGN); + tmp = hcl_remakengcbytearray (hcl, (hcl_oop_t)hcl->code.bc.arr, newcapa); if (!tmp) return -1; - hcl->code.bc.arr = tmp; + hcl->code.bc.arr = (hcl_oop_byte_t)tmp; } - ((hcl_oop_byte_t)hcl->code.bc.arr)->slot[hcl->code.bc.len++] = bc; + hcl->code.bc.arr->slot[hcl->code.bc.len++] = bc; return 0; } @@ -920,9 +932,18 @@ static HCL_INLINE int compile_symbol (hcl_t* hcl, hcl_oop_t obj) /* check if a symbol is a local variable */ if (find_temporary_variable_backward (hcl, obj, &index) <= -1) { + hcl_oop_t cons; /* TODO: if i require all variables to be declared, this part is not needed and should handle it as an error */ +/* TODO: change the scheme... allow declaration??? */ /* global variable */ - if (add_literal(hcl, obj, &index) <= -1 || + cons = (hcl_oop_t)hcl_getatsysdic (hcl, obj); + if (!cons) + { + cons = (hcl_oop_t)hcl_putatsysdic (hcl, obj, hcl->_nil); + if (!cons) return -1; + } + + if (add_literal(hcl, cons, &index) <= -1 || emit_single_param_instruction (hcl, HCL_CODE_PUSH_OBJECT_0, index) <= -1) return -1; return 0; @@ -1053,9 +1074,11 @@ static HCL_INLINE int emit_lambda (hcl_t* hcl) /* no body in lambda - (lambda (a b c)) */ /* TODO: is this correct??? */ if (emit_byte_instruction(hcl, HCL_CODE_PUSH_NIL) <= -1) return -1; + block_code_size++; } if (emit_byte_instruction (hcl, HCL_CODE_RETURN_FROM_BLOCK) <= -1) return -1; + block_code_size++; if (block_code_size > MAX_CODE_JUMP * 2) { @@ -1132,10 +1155,18 @@ static HCL_INLINE int emit_set (hcl_t* hcl) if (cf->u.set.var_type == VAR_NAMED) { hcl_oow_t index; + hcl_oop_t cons; HCL_ASSERT (HCL_IS_SYMBOL(hcl, cf->operand)); - if (add_literal(hcl, cf->operand, &index) <= -1 || + cons = (hcl_oop_t)hcl_getatsysdic (hcl, cf->operand); + if (!cons) + { + cons = (hcl_oop_t)hcl_putatsysdic (hcl, cf->operand, hcl->_nil); + if (!cons) return -1; + } + + if (add_literal(hcl, cons, &index) <= -1 || emit_single_param_instruction(hcl, HCL_CODE_STORE_INTO_OBJECT_0, index) <= -1) return -1; } else diff --git a/lib/decode.c b/lib/decode.c index 46ab1bb..aa61167 100644 --- a/lib/decode.c +++ b/lib/decode.c @@ -47,15 +47,18 @@ #endif /* TODO: check if ip shoots beyond the maximum length in fetching code and parameters */ -int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end) +int hcl_decode (hcl_t* hcl, hcl_ooi_t start, hcl_ooi_t end) { hcl_oob_t bcode, * cdptr; - hcl_oow_t ip = start; - hcl_ooi_t b1, b2; + hcl_ooi_t ip = start; + hcl_oow_t b1, b2; /* the instruction at the offset 'end' is not decoded. * decoding offset range is from start to end - 1. */ - HCL_ASSERT (end <= hcl->code.bc.len); + + HCL_ASSERT (start >= 0 && end >= 0); + HCL_ASSERT (hcl->code.bc.len < HCL_SMOOI_MAX); /* asserted by the compiler */ + HCL_ASSERT (end <= hcl->code.bc.len); /* not harmful though this fails */ ip = start; cdptr = ((hcl_oop_byte_t)hcl->code.bc.arr)->slot; @@ -80,7 +83,7 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end) case BCODE_PUSH_INSTVAR_7: b1 = bcode & 0x7; /* low 3 bits */ push_instvar: - LOG_INST_1 (hcl, "push_instvar %zd", b1); + LOG_INST_1 (hcl, "push_instvar %zu", b1); break; /* ------------------------------------------------- */ @@ -98,7 +101,7 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end) case BCODE_STORE_INTO_INSTVAR_7: b1 = bcode & 0x7; /* low 3 bits */ store_instvar: - LOG_INST_1 (hcl, "store_into_instvar %zd", b1); + LOG_INST_1 (hcl, "store_into_instvar %zu", b1); break; case BCODE_POP_INTO_INSTVAR_X: @@ -114,7 +117,7 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end) case BCODE_POP_INTO_INSTVAR_7: b1 = bcode & 0x7; /* low 3 bits */ pop_into_instvar: - LOG_INST_1 (hcl, "pop_into_instvar %zd", b1); + LOG_INST_1 (hcl, "pop_into_instvar %zu", b1); break; /* ------------------------------------------------- */ @@ -154,7 +157,7 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end) if ((bcode >> 4) & 1) { /* push - bit 4 on */ - LOG_INST_1 (hcl, "push_tempvar %zd", b1); + LOG_INST_1 (hcl, "push_tempvar %zu", b1); } else { @@ -162,11 +165,11 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end) if ((bcode >> 3) & 1) { /* pop - bit 3 on */ - LOG_INST_1 (hcl, "pop_into_tempvar %zd", b1); + LOG_INST_1 (hcl, "pop_into_tempvar %zu", b1); } else { - LOG_INST_1 (hcl, "store_into_tempvar %zd", b1); + LOG_INST_1 (hcl, "store_into_tempvar %zu", b1); } } break; @@ -196,7 +199,7 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end) case HCL_CODE_PUSH_LITERAL_7: b1 = bcode & 0x7; /* low 3 bits */ push_literal: - LOG_INST_1 (hcl, "push_literal @%zd", b1); + LOG_INST_1 (hcl, "push_literal @%zu", b1); break; /* ------------------------------------------------- */ @@ -224,16 +227,16 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end) { if ((bcode >> 2) & 1) { - LOG_INST_1 (hcl, "pop_into_object @%zd", b1); + LOG_INST_1 (hcl, "pop_into_object @%zu", b1); } else { - LOG_INST_1 (hcl, "store_into_object @%zd", b1); + LOG_INST_1 (hcl, "store_into_object @%zu", b1); } } else { - LOG_INST_1 (hcl, "push_object @%zd", b1); + LOG_INST_1 (hcl, "push_object @%zu", b1); } break; @@ -241,19 +244,19 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end) case HCL_CODE_JUMP_FORWARD_X: FETCH_PARAM_CODE_TO (hcl, b1); - LOG_INST_1 (hcl, "jump_forward %zd", b1); + LOG_INST_1 (hcl, "jump_forward %zu", b1); break; case HCL_CODE_JUMP_FORWARD_0: case HCL_CODE_JUMP_FORWARD_1: case HCL_CODE_JUMP_FORWARD_2: case HCL_CODE_JUMP_FORWARD_3: - LOG_INST_1 (hcl, "jump_forward %zd", (bcode & 0x3)); /* low 2 bits */ + LOG_INST_1 (hcl, "jump_forward %zu", (hcl_oow_t)(bcode & 0x3)); /* low 2 bits */ break; case HCL_CODE_JUMP_BACKWARD_X: FETCH_PARAM_CODE_TO (hcl, b1); - LOG_INST_1 (hcl, "jump_backward %zd", b1); + LOG_INST_1 (hcl, "jump_backward %zu", b1); hcl->ip += b1; break; @@ -261,7 +264,7 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end) case HCL_CODE_JUMP_BACKWARD_1: case HCL_CODE_JUMP_BACKWARD_2: case HCL_CODE_JUMP_BACKWARD_3: - LOG_INST_1 (hcl, "jump_backward %zd", (bcode & 0x3)); /* low 2 bits */ + LOG_INST_1 (hcl, "jump_backward %zu", (hcl_oow_t)(bcode & 0x3)); /* low 2 bits */ break; case BCODE_JUMP_IF_TRUE_X: @@ -280,12 +283,12 @@ return -1; case HCL_CODE_JUMP2_FORWARD: FETCH_PARAM_CODE_TO (hcl, b1); - LOG_INST_1 (hcl, "jump2_forward %zd", b1); + LOG_INST_1 (hcl, "jump2_forward %zu", b1); break; case HCL_CODE_JUMP2_BACKWARD: FETCH_PARAM_CODE_TO (hcl, b1); - LOG_INST_1 (hcl, "jump2_backward %zd", b1); + LOG_INST_1 (hcl, "jump2_backward %zu", b1); break; /* -------------------------------------------------------- */ @@ -300,7 +303,7 @@ return -1; case HCL_CODE_CALL_3: b1 = bcode & 0x3; /* low 2 bits */ handle_call: - LOG_INST_1 (hcl, "call %zd", b1); + LOG_INST_1 (hcl, "call %zu", b1); break; /* -------------------------------------------------------- */ @@ -333,17 +336,17 @@ return -1; if ((bcode >> 2) & 1) { - LOG_INST_2 (hcl, "pop_into_ctxtempvar %zd %zd", b1, b2); + LOG_INST_2 (hcl, "pop_into_ctxtempvar %zu %zu", b1, b2); } else { - LOG_INST_2 (hcl, "store_into_ctxtempvar %zd %zd", b1, b2); + LOG_INST_2 (hcl, "store_into_ctxtempvar %zu %zu", b1, b2); } } else { /* push */ - LOG_INST_2 (hcl, "push_ctxtempvar %zd %zd", b1, b2); + LOG_INST_2 (hcl, "push_ctxtempvar %zu %zu", b1, b2); } break; @@ -379,16 +382,16 @@ return -1; /* store or pop */ if ((bcode >> 2) & 1) { - LOG_INST_2 (hcl, "pop_into_objvar %zd %zd", b1, b2); + LOG_INST_2 (hcl, "pop_into_objvar %zu %zu", b1, b2); } else { - LOG_INST_2 (hcl, "store_into_objvar %zd %zd", b1, b2); + LOG_INST_2 (hcl, "store_into_objvar %zu %zu", b1, b2); } } else { - LOG_INST_2 (hcl, "push_objvar %zd %zd", b1, b2); + LOG_INST_2 (hcl, "push_objvar %zu %zu", b1, b2); } break; @@ -414,7 +417,7 @@ return -1; FETCH_BYTE_CODE_TO (hcl, b2); handle_send_message: - LOG_INST_3 (hcl, "send_message%hs %zd @%zd", (((bcode >> 2) & 1)? "_to_super": ""), b1, b2); + LOG_INST_3 (hcl, "send_message%hs %zu @%zu", (((bcode >> 2) & 1)? "_to_super": ""), b1, b2); break; /* -------------------------------------------------------- */ @@ -461,17 +464,17 @@ return -1; case HCL_CODE_PUSH_INTLIT: FETCH_PARAM_CODE_TO (hcl, b1); - LOG_INST_1 (hcl, "push_intlit %zd", b1); + LOG_INST_1 (hcl, "push_intlit %zu", b1); break; case HCL_CODE_PUSH_NEGINTLIT: FETCH_PARAM_CODE_TO (hcl, b1); - LOG_INST_1 (hcl, "push_negintlit %zd", -b1); + LOG_INST_1 (hcl, "push_negintlit %zu", b1); break; case HCL_CODE_PUSH_CHARLIT: FETCH_PARAM_CODE_TO (hcl, b1); - LOG_INST_1 (hcl, "push_charlit %zd", b1); + LOG_INST_1 (hcl, "push_charlit %zu", b1); break; /* -------------------------------------------------------- */ @@ -501,7 +504,7 @@ return -1; FETCH_PARAM_CODE_TO (hcl, b1); FETCH_PARAM_CODE_TO (hcl, b2); - LOG_INST_2 (hcl, "make_block %zd %zd", b1, b2); + LOG_INST_2 (hcl, "make_block %zu %zu", b1, b2); HCL_ASSERT (b1 >= 0); HCL_ASSERT (b2 >= b1); @@ -520,14 +523,13 @@ return -1; LOG_INST_1 (hcl, "UNKNOWN BYTE CODE ENCOUNTERED %x", (int)bcode); hcl->errnum = HCL_EINTERN; break; - } } /* print literal frame contents */ for (ip = 0; ip < hcl->code.lit.len; ip++) { - LOG_INST_2 (hcl, " @%-3lu %O", (unsigned long int)ip, ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[ip]); + LOG_INST_2 (hcl, " @%-3zd %O", ip, ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[ip]); } return 0; diff --git a/lib/dic.c b/lib/dic.c index 593c8b6..f5d4a9f 100644 --- a/lib/dic.c +++ b/lib/dic.c @@ -94,9 +94,9 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_set_t dic, hcl_oop_cha /* the system dictionary is not a generic dictionary. * it accepts only a symbol as a key. */ - HCL_ASSERT (HCL_BRANDOF(hcl,key) == HCL_BRAND_SYMBOL); + HCL_ASSERT (HCL_IS_SYMBOL(hcl,key)); HCL_ASSERT (HCL_OOP_IS_SMOOI(dic->tally)); - HCL_ASSERT (HCL_BRANDOF(hcl,dic->bucket) == HCL_BRAND_INTEGER); + HCL_ASSERT (HCL_IS_ARRAY(hcl,dic->bucket)); index = hcl_hashchars(key->slot, HCL_OBJ_GET_SIZE(key)) % HCL_OBJ_GET_SIZE(dic->bucket); @@ -225,13 +225,13 @@ static hcl_oop_cons_t lookup (hcl_t* hcl, hcl_oop_set_t dic, const hcl_oocs_t* n hcl_oop_cons_t hcl_putatsysdic (hcl_t* hcl, hcl_oop_t key, hcl_oop_t value) { - HCL_ASSERT (HCL_BRANDOF(hcl,key) == HCL_BRAND_SYMBOL); + HCL_ASSERT (HCL_IS_SYMBOL(hcl,key)); return find_or_upsert (hcl, hcl->sysdic, (hcl_oop_char_t)key, value); } hcl_oop_cons_t hcl_getatsysdic (hcl_t* hcl, hcl_oop_t key) { - HCL_ASSERT (HCL_BRANDOF(hcl,key) == HCL_BRAND_SYMBOL); + HCL_ASSERT (HCL_IS_SYMBOL(hcl,key)); return find_or_upsert (hcl, hcl->sysdic, (hcl_oop_char_t)key, HCL_NULL); } diff --git a/lib/exec.c b/lib/exec.c index 16e7782..1974e68 100644 --- a/lib/exec.c +++ b/lib/exec.c @@ -27,4 +27,2224 @@ #include "hcl-prv.h" +/* TODO: remove these headers after having migrated system-dependent functions of of this file */ +#if defined(_WIN32) +# include +#elif defined(__OS2__) +# define INCL_DOSMISC +# define INCL_DOSDATETIME +# define INCL_DOSERRORS +# include +# include +#elif defined(__MSDOS__) +# include +#elif defined(macintosh) +# include +# include +# include +#else +# if defined(HAVE_TIME_H) +# include +# endif +# if defined(HAVE_SYS_TIME_H) +# include +# endif +#endif + +#define PROC_STATE_RUNNING 3 +#define PROC_STATE_WAITING 2 +#define PROC_STATE_RUNNABLE 1 +#define PROC_STATE_SUSPENDED 0 +#define PROC_STATE_TERMINATED -1 + +#define SEM_LIST_INC 256 +#define SEM_HEAP_INC 256 +#define SEM_LIST_MAX (SEM_LIST_INC * 1000) +#define SEM_HEAP_MAX (SEM_HEAP_INC * 1000) + +#define SEM_HEAP_PARENT(x) (((x) - 1) / 2) +#define SEM_HEAP_LEFT(x) ((x) * 2 + 1) +#define SEM_HEAP_RIGHT(x) ((x) * 2 + 2) + +#define SEM_HEAP_EARLIER_THAN(stx,x,y) ( \ + (HCL_OOP_TO_SMOOI((x)->heap_ftime_sec) < HCL_OOP_TO_SMOOI((y)->heap_ftime_sec)) || \ + (HCL_OOP_TO_SMOOI((x)->heap_ftime_sec) == HCL_OOP_TO_SMOOI((y)->heap_ftime_sec) && HCL_OOP_TO_SMOOI((x)->heap_ftime_nsec) < HCL_OOP_TO_SMOOI((y)->heap_ftime_nsec)) \ +) + + +#define LOAD_IP(hcl, v_ctx) ((hcl)->ip = HCL_OOP_TO_SMOOI((v_ctx)->ip)) +#define STORE_IP(hcl, v_ctx) ((v_ctx)->ip = HCL_SMOOI_TO_OOP((hcl)->ip)) + +#define LOAD_SP(hcl, v_ctx) ((hcl)->sp = HCL_OOP_TO_SMOOI((v_ctx)->sp)) +#define STORE_SP(hcl, v_ctx) ((v_ctx)->sp = HCL_SMOOI_TO_OOP((hcl)->sp)) + +#define LOAD_ACTIVE_IP(hcl) LOAD_IP(hcl, (hcl)->active_context) +#define STORE_ACTIVE_IP(hcl) STORE_IP(hcl, (hcl)->active_context) + +#define LOAD_ACTIVE_SP(hcl) LOAD_SP(hcl, (hcl)->processor->active) +#define STORE_ACTIVE_SP(hcl) STORE_SP(hcl, (hcl)->processor->active) + +#define SWITCH_ACTIVE_CONTEXT(hcl,v_ctx) \ + do \ + { \ + STORE_ACTIVE_IP (hcl); \ + (hcl)->active_context = (v_ctx); \ + LOAD_ACTIVE_IP (hcl); \ + (hcl)->processor->active->current_context = (hcl)->active_context; \ + } while (0) + + +#define FETCH_BYTE_CODE(hcl) ((hcl)->code.bc.arr->slot[(hcl)->ip++]) +#define FETCH_BYTE_CODE_TO(hcl, v_oow) (v_oow = FETCH_BYTE_CODE(hcl)) +#if (HCL_BCODE_LONG_PARAM_SIZE == 2) +# define FETCH_PARAM_CODE_TO(hcl, v_oow) \ + do { \ + v_oow = FETCH_BYTE_CODE(hcl); \ + v_oow = (v_oow << 8) | FETCH_BYTE_CODE(hcl); \ + } while (0) +#else +# define FETCH_PARAM_CODE_TO(hcl, v_oow) (v_oow = FETCH_BYTE_CODE(hcl)) +#endif + + +#if defined(HCL_DEBUG_VM_EXEC) +# define LOG_MASK_INST (HCL_LOG_IC | HCL_LOG_MNEMONIC) + +# define LOG_INST_0(hcl,fmt) HCL_LOG0(hcl, LOG_MASK_INST, "\t" fmt "\n") +# define LOG_INST_1(hcl,fmt,a1) HCL_LOG1(hcl, LOG_MASK_INST, "\t" fmt "\n",a1) +# define LOG_INST_2(hcl,fmt,a1,a2) HCL_LOG2(hcl, LOG_MASK_INST, "\t" fmt "\n", a1, a2) +# define LOG_INST_3(hcl,fmt,a1,a2,a3) HCL_LOG3(hcl, LOG_MASK_INST, "\t" fmt "\n", a1, a2, a3) + +#else +# define LOG_INST_0(hcl,fmt) +# define LOG_INST_1(hcl,fmt,a1) +# define LOG_INST_2(hcl,fmt,a1,a2) +# define LOG_INST_3(hcl,fmt,a1,a2,a3) +#endif + +/* ------------------------------------------------------------------------- */ +static HCL_INLINE void vm_gettime (hcl_t* hcl, hcl_ntime_t* now) +{ +#if defined(_WIN32) + + /* TODO: */ + +#elif defined(__OS2__) + ULONG out; + +/* TODO: handle overflow?? */ +/* TODO: use DosTmrQueryTime() and DosTmrQueryFreq()? */ + DosQuerySysInfo (QSV_MS_COUNT, QSV_MS_COUNT, &out, HCL_SIZEOF(out)); /* milliseconds */ + /* it must return NO_ERROR */ + + HCL_INITNTIME (now, HCL_MSEC_TO_SEC(out), HCL_MSEC_TO_NSEC(out)); +#elif defined(__MSDOS__) && defined(_INTELC32_) + clock_t c; + +/* TODO: handle overflow?? */ + c = clock (); + now->sec = c / CLOCKS_PER_SEC; + #if (CLOCKS_PER_SEC == 1000) + now->nsec = HCL_MSEC_TO_NSEC(c % CLOCKS_PER_SEC); + #elif (CLOCKS_PER_SEC == 1000000L) + now->nsec = HCL_USEC_TO_NSEC(c % CLOCKS_PER_SEC); + #elif (CLOCKS_PER_SEC == 1000000000L) + now->nsec = (c % CLOCKS_PER_SEC); + #else + # error UNSUPPORTED CLOCKS_PER_SEC + #endif +#elif defined(macintosh) + UnsignedWide tick; + hcl_uint64_t tick64; + + Microseconds (&tick); + + tick64 = *(hcl_uint64_t*)&tick; + HCL_INITNTIME (now, HCL_USEC_TO_SEC(tick64), HCL_USEC_TO_NSEC(tick64)); + +#elif defined(HAVE_CLOCK_GETTIME) && defined(CLOCK_MONOTONIC) + struct timespec ts; + clock_gettime (CLOCK_MONOTONIC, &ts); + HCL_INITNTIME(now, ts.tv_sec, ts.tv_nsec); + +#elif defined(HAVE_CLOCK_GETTIME) && defined(CLOCK_REALTIME) + struct timespec ts; + clock_gettime (CLOCK_REALTIME, &ts); + HCL_INITNTIME(now, ts.tv_sec, ts.tv_nsec); + HCL_SUBNTIME (now, now, &hcl->vm_time_offset); /* offset */ +#else + struct timeval tv; + gettimeofday (&tv, HCL_NULL); + HCL_INITNTIME(now, tv.tv_sec, HCL_USEC_TO_NSEC(tv.tv_usec)); + + /* at the first call, vm_time_offset should be 0. so subtraction takes + * no effect. once it becomes non-zero, it offsets the actual time. + * this is to keep the returned time small enough to be held in a + * small integer on platforms where the small integer is not large enough */ + HCL_SUBNTIME (now, now, &hcl->vm_time_offset); +#endif +} + +static HCL_INLINE void vm_sleep (hcl_t* hcl, const hcl_ntime_t* dur) +{ +#if defined(_WIN32) + if (hcl->waitable_timer) + { + LARGE_INTEGER li; + li.QuadPart = -HCL_SECNSEC_TO_NSEC(dur->sec, dur->nsec); + if(SetWaitableTimer(timer, &li, 0, HCL_NULL, HCL_NULL, FALSE) == FALSE) goto normal_sleep; + WaitForSingleObject(timer, INFINITE); + } + else + { + normal_sleep: + /* fallback to normal Sleep() */ + Sleep (HCL_SECNSEC_TO_MSEC(dur->sec,dur->nsec)); + } +#elif defined(__OS2__) + + /* TODO: in gui mode, this is not a desirable method??? + * this must be made event-driven coupled with the main event loop */ + DosSleep (HCL_SECNSEC_TO_MSEC(dur->sec,dur->nsec)); + +#elif defined(macintosh) + + /* TODO: ... */ + +#elif defined(__MSDOS__) && defined(_INTELC32_) + + clock_t c; + + c = clock (); + c += dur->sec * CLOCKS_PER_SEC; + #if (CLOCKS_PER_SEC == 1000) + c += HCL_NSEC_TO_MSEC(dur->nsec); + #elif (CLOCKS_PER_SEC == 1000000L) + c += HCL_NSEC_TO_USEC(dur->nsec); + #elif (CLOCKS_PER_SEC == 1000000000L) + c += dur->nsec; + #else + # error UNSUPPORTED CLOCKS_PER_SEC + #endif + +/* TODO: handle clock overvlow */ +/* TODO: check if there is abortion request or interrupt */ + while (c > clock()) ; + +#else + struct timespec ts; + ts.tv_sec = dur->sec; + ts.tv_nsec = dur->nsec; + nanosleep (&ts, HCL_NULL); +#endif +} + + +static void vm_startup (hcl_t* hcl) +{ + hcl_ntime_t now; + +#if defined(_WIN32) + hcl->waitable_timer = CreateWaitableTimer(HCL_NULL, TRUE, HCL_NULL); +#endif + + /* reset hcl->vm_time_offset so that vm_gettime is not affected */ + HCL_INITNTIME(&hcl->vm_time_offset, 0, 0); + vm_gettime (hcl, &now); + hcl->vm_time_offset = now; +} + +static void vm_cleanup (hcl_t* hcl) +{ +#if defined(_WIN32) + if (hcl->waitable_timer) + { + CloseHandle (hcl->waitable_timer); + hcl->waitable_timer = HCL_NULL; + } +#endif +} + +/* ------------------------------------------------------------------------- */ + + +static HCL_INLINE hcl_oop_t make_context (hcl_t* hcl, hcl_ooi_t ntmprs) +{ + HCL_ASSERT (ntmprs >= 0); + return hcl_allocoopobj (hcl, HCL_BRAND_CONTEXT, HCL_CONTEXT_NAMED_INSTVARS + (hcl_oow_t)ntmprs); +} + +static hcl_oop_process_t make_process (hcl_t* hcl, hcl_oop_context_t c) +{ + hcl_oop_process_t proc; + hcl_oow_t stksize; + + stksize = hcl->option.dfl_procstk_size; + if (stksize > HCL_TYPE_MAX(hcl_oow_t) - HCL_PROCESS_NAMED_INSTVARS) + stksize = HCL_TYPE_MAX(hcl_oow_t) - HCL_PROCESS_NAMED_INSTVARS; + + hcl_pushtmp (hcl, (hcl_oop_t*)&c); + proc = (hcl_oop_process_t)hcl_allocoopobj (hcl, HCL_BRAND_PROCESS, HCL_PROCESS_NAMED_INSTVARS + stksize); + hcl_poptmp (hcl); + if (!proc) return HCL_NULL; + + proc->state = HCL_SMOOI_TO_OOP(PROC_STATE_SUSPENDED); + proc->initial_context = c; + proc->current_context = c; + proc->sp = HCL_SMOOI_TO_OOP(-1); + + HCL_ASSERT ((hcl_oop_t)c->sender == hcl->_nil); + +#if defined(HCL_DEBUG_VM_PROCESSOR) + HCL_LOG2 (hcl, HCL_LOG_IC | HCL_LOG_DEBUG, "Processor - made process %O of size %zu\n", proc, HCL_OBJ_GET_SIZE(proc)); +#endif + return proc; +} + +static HCL_INLINE void sleep_active_process (hcl_t* hcl, int state) +{ +#if defined(HCL_DEBUG_VM_PROCESSOR) + HCL_LOG3 (hcl, HCL_LOG_IC | HCL_LOG_DEBUG, "Processor - put process %O context %O ip=%zd to sleep\n", hcl->processor->active, hcl->active_context, hcl->ip); +#endif + + STORE_ACTIVE_SP(hcl); + + /* store the current active context to the current process. + * it is the suspended context of the process to be suspended */ + HCL_ASSERT (hcl->processor->active != hcl->nil_process); + hcl->processor->active->current_context = hcl->active_context; + hcl->processor->active->state = HCL_SMOOI_TO_OOP(state); +} + +static HCL_INLINE void wake_new_process (hcl_t* hcl, hcl_oop_process_t proc) +{ + /* activate the given process */ + proc->state = HCL_SMOOI_TO_OOP(PROC_STATE_RUNNING); + hcl->processor->active = proc; + + LOAD_ACTIVE_SP(hcl); + + /* activate the suspended context of the new process */ + SWITCH_ACTIVE_CONTEXT (hcl, proc->current_context); + +#if defined(HCL_DEBUG_VM_PROCESSOR) + HCL_LOG3 (hcl, HCL_LOG_IC | HCL_LOG_DEBUG, "Processor - woke up process %O context %O ip=%zd\n", hcl->processor->active, hcl->active_context, hcl->ip); +#endif +} + +static void switch_to_process (hcl_t* hcl, hcl_oop_process_t proc, int new_state_for_old_active) +{ + /* the new process must not be the currently active process */ + HCL_ASSERT (hcl->processor->active != proc); + + /* the new process must be in the runnable state */ + HCL_ASSERT (proc->state == HCL_SMOOI_TO_OOP(PROC_STATE_RUNNABLE) || + proc->state == HCL_SMOOI_TO_OOP(PROC_STATE_WAITING)); + + sleep_active_process (hcl, new_state_for_old_active); + wake_new_process (hcl, proc); + + hcl->proc_switched = 1; +} + +static HCL_INLINE hcl_oop_process_t find_next_runnable_process (hcl_t* hcl) +{ + hcl_oop_process_t npr; + + HCL_ASSERT (hcl->processor->active->state == HCL_SMOOI_TO_OOP(PROC_STATE_RUNNING)); + npr = hcl->processor->active->next; + if ((hcl_oop_t)npr == hcl->_nil) npr = hcl->processor->runnable_head; + return npr; +} + +static HCL_INLINE void switch_to_next_runnable_process (hcl_t* hcl) +{ + hcl_oop_process_t nrp; + + nrp = find_next_runnable_process (hcl); + if (nrp != hcl->processor->active) switch_to_process (hcl, nrp, PROC_STATE_RUNNABLE); +} + +static HCL_INLINE int chain_into_processor (hcl_t* hcl, hcl_oop_process_t proc) +{ + /* the process is not scheduled at all. + * link it to the processor's process list. */ + hcl_ooi_t tally; + + HCL_ASSERT ((hcl_oop_t)proc->prev == hcl->_nil); + HCL_ASSERT ((hcl_oop_t)proc->next == hcl->_nil); + + HCL_ASSERT (proc->state == HCL_SMOOI_TO_OOP(PROC_STATE_SUSPENDED)); + + tally = HCL_OOP_TO_SMOOI(hcl->processor->tally); + + HCL_ASSERT (tally >= 0); + if (tally >= HCL_SMOOI_MAX) + { +#if defined(HCL_DEBUG_VM_PROCESSOR) + HCL_LOG0 (hcl, HCL_LOG_IC | HCL_LOG_FATAL, "Processor - too many process\n"); +#endif + hcl->errnum = HCL_EPFULL; + return -1; + } + + /* append to the runnable list */ + if (tally > 0) + { + proc->prev = hcl->processor->runnable_tail; + hcl->processor->runnable_tail->next = proc; + } + else + { + hcl->processor->runnable_head = proc; + } + hcl->processor->runnable_tail = proc; + + tally++; + hcl->processor->tally = HCL_SMOOI_TO_OOP(tally); + + return 0; +} + +static HCL_INLINE void unchain_from_processor (hcl_t* hcl, hcl_oop_process_t proc, int state) +{ + hcl_ooi_t tally; + + /* the processor's process chain must be composed of running/runnable + * processes only */ + HCL_ASSERT (proc->state == HCL_SMOOI_TO_OOP(PROC_STATE_RUNNING) || + proc->state == HCL_SMOOI_TO_OOP(PROC_STATE_RUNNABLE)); + + tally = HCL_OOP_TO_SMOOI(hcl->processor->tally); + HCL_ASSERT (tally > 0); + + if ((hcl_oop_t)proc->prev != hcl->_nil) proc->prev->next = proc->next; + else hcl->processor->runnable_head = proc->next; + if ((hcl_oop_t)proc->next != hcl->_nil) proc->next->prev = proc->prev; + else hcl->processor->runnable_tail = proc->prev; + + proc->prev = (hcl_oop_process_t)hcl->_nil; + proc->next = (hcl_oop_process_t)hcl->_nil; + proc->state = HCL_SMOOI_TO_OOP(state); + + tally--; + if (tally == 0) hcl->processor->active = hcl->nil_process; + hcl->processor->tally = HCL_SMOOI_TO_OOP(tally); +} + +static HCL_INLINE void chain_into_semaphore (hcl_t* hcl, hcl_oop_process_t proc, hcl_oop_semaphore_t sem) +{ + /* append a process to the process list of a semaphore*/ + + HCL_ASSERT ((hcl_oop_t)proc->sem == hcl->_nil); + HCL_ASSERT ((hcl_oop_t)proc->prev == hcl->_nil); + HCL_ASSERT ((hcl_oop_t)proc->next == hcl->_nil); + + if ((hcl_oop_t)sem->waiting_head == hcl->_nil) + { + HCL_ASSERT ((hcl_oop_t)sem->waiting_tail == hcl->_nil); + sem->waiting_head = proc; + } + else + { + proc->prev = sem->waiting_tail; + sem->waiting_tail->next = proc; + } + sem->waiting_tail = proc; + + proc->sem = sem; +} + +static HCL_INLINE void unchain_from_semaphore (hcl_t* hcl, hcl_oop_process_t proc) +{ + hcl_oop_semaphore_t sem; + + HCL_ASSERT ((hcl_oop_t)proc->sem != hcl->_nil); + + sem = proc->sem; + if ((hcl_oop_t)proc->prev != hcl->_nil) proc->prev->next = proc->next; + else sem->waiting_head = proc->next; + if ((hcl_oop_t)proc->next != hcl->_nil) proc->next->prev = proc->prev; + else sem->waiting_tail = proc->prev; + + proc->prev = (hcl_oop_process_t)hcl->_nil; + proc->next = (hcl_oop_process_t)hcl->_nil; + + proc->sem = (hcl_oop_semaphore_t)hcl->_nil; +} + +static void terminate_process (hcl_t* hcl, hcl_oop_process_t proc) +{ + if (proc->state == HCL_SMOOI_TO_OOP(PROC_STATE_RUNNING) || + proc->state == HCL_SMOOI_TO_OOP(PROC_STATE_RUNNABLE)) + { + /* RUNNING/RUNNABLE ---> TERMINATED */ + + #if defined(HCL_DEBUG_VM_PROCESSOR) + HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_DEBUG, "Processor - process %O RUNNING/RUNNABLE->TERMINATED\n", proc); + #endif + + if (proc == hcl->processor->active) + { + hcl_oop_process_t nrp; + + nrp = find_next_runnable_process (hcl); + + unchain_from_processor (hcl, proc, PROC_STATE_TERMINATED); + proc->sp = HCL_SMOOI_TO_OOP(-1); /* invalidate the process stack */ + proc->current_context = proc->initial_context; /* not needed but just in case */ + + /* a runnable or running process must not be chanined to the + * process list of a semaphore */ + HCL_ASSERT ((hcl_oop_t)proc->sem == hcl->_nil); + + if (nrp == proc) + { + /* no runnable process after termination */ + HCL_ASSERT (hcl->processor->active == hcl->nil_process); + HCL_LOG0 (hcl, HCL_LOG_IC | HCL_LOG_DEBUG, "No runnable process after process termination\n"); + } + else + { + switch_to_process (hcl, nrp, PROC_STATE_TERMINATED); + } + } + else + { + unchain_from_processor (hcl, proc, PROC_STATE_TERMINATED); + proc->sp = HCL_SMOOI_TO_OOP(-1); /* invalidate the process stack */ + } + } + else if (proc->state == HCL_SMOOI_TO_OOP(PROC_STATE_SUSPENDED)) + { + /* SUSPENDED ---> TERMINATED */ + #if defined(HCL_DEBUG_VM_PROCESSOR) + HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_DEBUG, "Processor - process %O SUSPENDED->TERMINATED\n", proc); + #endif + + proc->state = HCL_SMOOI_TO_OOP(PROC_STATE_TERMINATED); + proc->sp = HCL_SMOOI_TO_OOP(-1); /* invalidate the proce stack */ + + if ((hcl_oop_t)proc->sem != hcl->_nil) + { + unchain_from_semaphore (hcl, proc); + } + } + else if (proc->state == HCL_SMOOI_TO_OOP(PROC_STATE_WAITING)) + { + /* WAITING ---> TERMINATED */ + /* TODO: */ + } +} + +static void resume_process (hcl_t* hcl, hcl_oop_process_t proc) +{ + if (proc->state == HCL_SMOOI_TO_OOP(PROC_STATE_SUSPENDED)) + { + /* SUSPENED ---> RUNNING */ + HCL_ASSERT ((hcl_oop_t)proc->prev == hcl->_nil); + HCL_ASSERT ((hcl_oop_t)proc->next == hcl->_nil); + + #if defined(HCL_DEBUG_VM_PROCESSOR) + HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_DEBUG, "Processor - process %O SUSPENDED->RUNNING\n", proc); + #endif + + chain_into_processor (hcl, proc); /* TODO: error check */ + + /*proc->current_context = proc->initial_context;*/ + proc->state = HCL_SMOOI_TO_OOP(PROC_STATE_RUNNABLE); + + /* don't switch to this process. just set the state to RUNNING */ + } +#if 0 + else if (proc->state == HCL_SMOOI_TO_OOP(PROC_STATE_RUNNABLE)) + { + /* RUNNABLE ---> RUNNING */ + /* TODO: should i allow this? */ + HCL_ASSERT (hcl->processor->active != proc); + switch_to_process (hcl, proc, PROC_STATE_RUNNABLE); + } +#endif +} + +static void suspend_process (hcl_t* hcl, hcl_oop_process_t proc) +{ + if (proc->state == HCL_SMOOI_TO_OOP(PROC_STATE_RUNNING) || + proc->state == HCL_SMOOI_TO_OOP(PROC_STATE_RUNNABLE)) + { + /* RUNNING/RUNNABLE ---> SUSPENDED */ + + #if defined(HCL_DEBUG_VM_PROCESSOR) + HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_DEBUG, "Processor - process %O RUNNING/RUNNABLE->SUSPENDED\n", proc); + #endif + + if (proc == hcl->processor->active) + { + hcl_oop_process_t nrp; + + nrp = find_next_runnable_process (hcl); + + if (nrp == proc) + { + /* no runnable process after suspension */ + sleep_active_process (hcl, PROC_STATE_RUNNABLE); + unchain_from_processor (hcl, proc, PROC_STATE_SUSPENDED); + + /* the last running/runnable process has been unchained + * from the processor and set to SUSPENDED. the active + * process must be the nil process */ + HCL_ASSERT (hcl->processor->active == hcl->nil_process); + } + else + { + /* keep the unchained process at the runnable state for + * the immediate call to switch_to_process() below */ + unchain_from_processor (hcl, proc, PROC_STATE_RUNNABLE); + /* unchain_from_processor() leaves the active process + * untouched unless the unchained process is the last + * running/runnable process. so calling switch_to_process() + * which expects the active process to be valid is safe */ + HCL_ASSERT (hcl->processor->active != hcl->nil_process); + switch_to_process (hcl, nrp, PROC_STATE_SUSPENDED); + } + } + else + { + unchain_from_processor (hcl, proc, PROC_STATE_SUSPENDED); + } + } +} + +static void yield_process (hcl_t* hcl, hcl_oop_process_t proc) +{ + if (proc->state == HCL_SMOOI_TO_OOP(PROC_STATE_RUNNING)) + { + /* RUNNING --> RUNNABLE */ + + hcl_oop_process_t nrp; + + HCL_ASSERT (proc == hcl->processor->active); + + nrp = find_next_runnable_process (hcl); + /* if there are more than 1 runnable processes, the next + * runnable process must be different from proc */ + if (nrp != proc) + { + #if defined(HCL_DEBUG_VM_PROCESSOR) + HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_DEBUG, "Processor - process %O RUNNING->RUNNABLE\n", proc); + #endif + switch_to_process (hcl, nrp, PROC_STATE_RUNNABLE); + } + } +} + +static int async_signal_semaphore (hcl_t* hcl, hcl_oop_semaphore_t sem) +{ + if (hcl->sem_list_count >= SEM_LIST_MAX) + { + hcl->errnum = HCL_ESLFULL; + return -1; + } + + if (hcl->sem_list_count >= hcl->sem_list_capa) + { + hcl_oow_t new_capa; + hcl_oop_semaphore_t* tmp; + + new_capa = hcl->sem_list_capa + SEM_LIST_INC; /* TODO: overflow check.. */ + tmp = hcl_reallocmem (hcl, hcl->sem_list, HCL_SIZEOF(hcl_oop_semaphore_t) * new_capa); + if (!tmp) return -1; + + hcl->sem_list = tmp; + hcl->sem_list_capa = new_capa; + } + + hcl->sem_list[hcl->sem_list_count] = sem; + hcl->sem_list_count++; + return 0; +} + +static hcl_oop_process_t signal_semaphore (hcl_t* hcl, hcl_oop_semaphore_t sem) +{ + hcl_oop_process_t proc; + hcl_ooi_t count; + + if ((hcl_oop_t)sem->waiting_head == hcl->_nil) + { + /* no process is waiting on this semaphore */ + count = HCL_OOP_TO_SMOOI(sem->count); + count++; + sem->count = HCL_SMOOI_TO_OOP(count); + + /* no process has been resumed */ + return (hcl_oop_process_t)hcl->_nil; + } + else + { + proc = sem->waiting_head; + + /* [NOTE] no GC must occur as 'proc' isn't protected with hcl_pushtmp(). */ + + unchain_from_semaphore (hcl, proc); + resume_process (hcl, proc); /* TODO: error check */ + + /* return the resumed process */ + return proc; + } +} + +static void await_semaphore (hcl_t* hcl, hcl_oop_semaphore_t sem) +{ + hcl_oop_process_t proc; + hcl_ooi_t count; + + count = HCL_OOP_TO_SMOOI(sem->count); + if (count > 0) + { + /* it's already signalled */ + count--; + sem->count = HCL_SMOOI_TO_OOP(count); + } + else + { + /* not signaled. need to wait */ + proc = hcl->processor->active; + + /* suspend the active process */ + suspend_process (hcl, proc); + + /* link the suspended process to the semaphore's process list */ + chain_into_semaphore (hcl, proc, sem); + + HCL_ASSERT (sem->waiting_tail == proc); + + HCL_ASSERT (hcl->processor->active != proc); + } +} + +static void sift_up_sem_heap (hcl_t* hcl, hcl_ooi_t index) +{ + if (index > 0) + { + hcl_ooi_t parent; + hcl_oop_semaphore_t sem, parsem; + + parent = SEM_HEAP_PARENT(index); + sem = hcl->sem_heap[index]; + parsem = hcl->sem_heap[parent]; + if (SEM_HEAP_EARLIER_THAN(hcl, sem, parsem)) + { + do + { + /* move down the parent to the current position */ + parsem->heap_index = HCL_SMOOI_TO_OOP(index); + hcl->sem_heap[index] = parsem; + + /* traverse up */ + index = parent; + if (index <= 0) break; + + parent = SEM_HEAP_PARENT(parent); + parsem = hcl->sem_heap[parent]; + } + while (SEM_HEAP_EARLIER_THAN(hcl, sem, parsem)); + + sem->heap_index = HCL_SMOOI_TO_OOP(index); + hcl->sem_heap[index] = sem; + } + } +} + +static void sift_down_sem_heap (hcl_t* hcl, hcl_ooi_t index) +{ + hcl_ooi_t base = hcl->sem_heap_count / 2; + + if (index < base) /* at least 1 child is under the 'index' position */ + { + hcl_ooi_t left, right, child; + hcl_oop_semaphore_t sem, chisem; + + sem = hcl->sem_heap[index]; + do + { + left = SEM_HEAP_LEFT(index); + right = SEM_HEAP_RIGHT(index); + + if (right < hcl->sem_heap_count && SEM_HEAP_EARLIER_THAN(hcl, hcl->sem_heap[left], hcl->sem_heap[right])) + { + child = right; + } + else + { + child = left; + } + + chisem = hcl->sem_heap[child]; + if (SEM_HEAP_EARLIER_THAN(hcl, sem, chisem)) break; + + chisem->heap_index = HCL_SMOOI_TO_OOP(index); + hcl->sem_heap[index ] = chisem; + + index = child; + } + while (index < base); + + sem->heap_index = HCL_SMOOI_TO_OOP(index); + hcl->sem_heap[index] = sem; + } +} + +static int add_to_sem_heap (hcl_t* hcl, hcl_oop_semaphore_t sem) +{ + hcl_ooi_t index; + + if (hcl->sem_heap_count >= SEM_HEAP_MAX) + { + hcl->errnum = HCL_ESHFULL; + return -1; + } + + if (hcl->sem_heap_count >= hcl->sem_heap_capa) + { + hcl_oow_t new_capa; + hcl_oop_semaphore_t* tmp; + + /* no overflow check when calculating the new capacity + * owing to SEM_HEAP_MAX check above */ + new_capa = hcl->sem_heap_capa + SEM_HEAP_INC; + tmp = hcl_reallocmem (hcl, hcl->sem_heap, HCL_SIZEOF(hcl_oop_semaphore_t) * new_capa); + if (!tmp) return -1; + + hcl->sem_heap = tmp; + hcl->sem_heap_capa = new_capa; + } + + HCL_ASSERT (hcl->sem_heap_count <= HCL_SMOOI_MAX); + + index = hcl->sem_heap_count; + hcl->sem_heap[index] = sem; + sem->heap_index = HCL_SMOOI_TO_OOP(index); + hcl->sem_heap_count++; + + sift_up_sem_heap (hcl, index); + return 0; +} + +static void delete_from_sem_heap (hcl_t* hcl, hcl_ooi_t index) +{ + hcl_oop_semaphore_t sem, lastsem; + + sem = hcl->sem_heap[index]; + sem->heap_index = HCL_SMOOI_TO_OOP(-1); + + hcl->sem_heap_count--; + if (hcl->sem_heap_count > 0 && index != hcl->sem_heap_count) + { + /* move the last item to the deletion position */ + lastsem = hcl->sem_heap[hcl->sem_heap_count]; + lastsem->heap_index = HCL_SMOOI_TO_OOP(index); + hcl->sem_heap[index] = lastsem; + + if (SEM_HEAP_EARLIER_THAN(hcl, lastsem, sem)) + sift_up_sem_heap (hcl, index); + else + sift_down_sem_heap (hcl, index); + } +} + +static void update_sem_heap (hcl_t* hcl, hcl_ooi_t index, hcl_oop_semaphore_t newsem) +{ + hcl_oop_semaphore_t sem; + + sem = hcl->sem_heap[index]; + sem->heap_index = HCL_SMOOI_TO_OOP(-1); + + newsem->heap_index = HCL_SMOOI_TO_OOP(index); + hcl->sem_heap[index] = newsem; + + if (SEM_HEAP_EARLIER_THAN(hcl, newsem, sem)) + sift_up_sem_heap (hcl, index); + else + sift_down_sem_heap (hcl, index); +} + +static int __activate_context (hcl_t* hcl, hcl_oop_context_t rcv_blkctx, hcl_ooi_t nargs, hcl_oop_context_t* pblkctx) +{ + /* prepare a new block context for activation. + * the receiver must be a block context which becomes the base + * for a new block context. */ + + hcl_oop_context_t blkctx; + hcl_ooi_t local_ntmprs, i; + + /* TODO: find a better way to support a reentrant block context. */ + + /* | sum | + * sum := [ :n | (n < 2) ifTrue: [1] ifFalse: [ n + (sum value: (n - 1))] ]. + * (sum value: 10). + * + * For the code above, sum is a block context and it is sent value: inside + * itself. Let me simply clone a block context to allow reentrancy like this + * while the block context is active + */ + + /* the receiver must be a block context */ + //HCL_ASSERT (HCL_CLASSOF(hcl, rcv_blkctx) == hcl->_block_context); + HCL_ASSERT (HCL_IS_CONTEXT (hcl, rcv_blkctx)); + if (rcv_blkctx->receiver_or_source != hcl->_nil) + { + /* the 'source' field is not nil. + * this block context has already been activated once. + * you can't send 'value' again to reactivate it. + * For example, [thisContext value] value. */ + HCL_ASSERT (HCL_OBJ_GET_SIZE(rcv_blkctx) > HCL_CONTEXT_NAMED_INSTVARS); + HCL_LOG1 (hcl, HCL_LOG_PRIMITIVE | HCL_LOG_ERROR, + "Error - re-valuing of a block context - %O\n", rcv_blkctx); + return 0; + } + HCL_ASSERT (HCL_OBJ_GET_SIZE(rcv_blkctx) == HCL_CONTEXT_NAMED_INSTVARS); + + if (HCL_OOP_TO_SMOOI(rcv_blkctx->method_or_nargs) != nargs) + { + HCL_LOG3 (hcl, HCL_LOG_PRIMITIVE | HCL_LOG_ERROR, + "Error - wrong number of arguments to a block context %O - expecting %zd, got %zd\n", + rcv_blkctx, HCL_OOP_TO_SMOOI(rcv_blkctx->method_or_nargs), nargs); + return 0; + } + + /* the number of temporaries stored in the block context + * accumulates the number of temporaries starting from the origin. + * simple calculation is needed to find the number of local temporaries */ + local_ntmprs = HCL_OOP_TO_SMOOI(rcv_blkctx->ntmprs) - + HCL_OOP_TO_SMOOI(((hcl_oop_context_t)rcv_blkctx->home)->ntmprs); +printf ("%d %d\n", (int)local_ntmprs, (int)nargs); + HCL_ASSERT (local_ntmprs >= nargs); + + + /* create a new block context to clone rcv_blkctx */ + hcl_pushtmp (hcl, (hcl_oop_t*)&rcv_blkctx); + blkctx = (hcl_oop_context_t) make_context (hcl, local_ntmprs); + hcl_poptmp (hcl); + if (!blkctx) return -1; + +#if 0 + /* shallow-copy the named part including home, origin, etc. */ + for (i = 0; i < HCL_CONTEXT_NAMED_INSTVARS; i++) + { + ((hcl_oop_oop_t)blkctx)->slot[i] = ((hcl_oop_oop_t)rcv_blkctx)->slot[i]; + } +#else + blkctx->ip = rcv_blkctx->ip; + blkctx->ntmprs = rcv_blkctx->ntmprs; + blkctx->method_or_nargs = rcv_blkctx->method_or_nargs; + blkctx->receiver_or_source = (hcl_oop_t)rcv_blkctx; + blkctx->home = rcv_blkctx->home; + blkctx->origin = rcv_blkctx->origin; +#endif + +/* TODO: check the stack size of a block context to see if it's large enough to hold arguments */ + /* copy the arguments to the stack */ + for (i = 0; i < nargs; i++) + { + blkctx->slot[i] = HCL_STACK_GETARG(hcl, nargs, 0); + } + + HCL_STACK_POPS (hcl, nargs + 1); /* pop arguments and receiver */ + + HCL_ASSERT (blkctx->home != hcl->_nil); + blkctx->sp = HCL_SMOOI_TO_OOP(-1); /* not important at all */ + blkctx->sender = hcl->active_context; + + *pblkctx = blkctx; + return 1; +} + +static int activate_context (hcl_t* hcl, hcl_ooi_t nargs) +{ + int x; + hcl_oop_context_t rcv_blkctx, blkctx; + + rcv_blkctx = (hcl_oop_context_t)HCL_STACK_GETRCV(hcl, nargs); + HCL_ASSERT (HCL_IS_CONTEXT (hcl, rcv_blkctx)); +#if 0 + if (HCL_CLASSOF(hcl, rcv_blkctx) != hcl->_block_context) + { + /* the receiver must be a block context */ + HCL_LOG1 (hcl, HCL_LOG_PRIMITIVE | HCL_LOG_ERROR, + "Error - invalid receiver, not a block context - %O\n", rcv_blkctx); + return 0; + } +#endif + + x = __activate_context (hcl, rcv_blkctx, nargs, &blkctx); + if (x <= 0) return x; /* hard failure and soft failure */ + + SWITCH_ACTIVE_CONTEXT (hcl, (hcl_oop_context_t)blkctx); + return 1; +} + + +static hcl_oop_process_t start_initial_process (hcl_t* hcl, hcl_oop_context_t ctx) +{ + hcl_oop_process_t proc; + + /* there must be no active process when this function is called */ + HCL_ASSERT (hcl->processor->tally == HCL_SMOOI_TO_OOP(0)); + HCL_ASSERT (hcl->processor->active == hcl->nil_process); + + proc = make_process (hcl, ctx); + if (!proc) return HCL_NULL; + + if (chain_into_processor (hcl, proc) <= -1) return HCL_NULL; + proc->state = HCL_SMOOI_TO_OOP(PROC_STATE_RUNNING); /* skip RUNNABLE and go to RUNNING */ + hcl->processor->active = proc; + + /* do something that resume_process() would do with less overhead */ + HCL_ASSERT ((hcl_oop_t)proc->current_context != hcl->_nil); + HCL_ASSERT (proc->current_context == proc->initial_context); + SWITCH_ACTIVE_CONTEXT (hcl, proc->current_context); + + return proc; +} + +static HCL_INLINE int activate_new_method (hcl_t* hcl, hcl_oop_method_t mth) +{ + hcl_oop_context_t ctx; + hcl_ooi_t i; + hcl_ooi_t ntmprs, nargs; + + ntmprs = HCL_OOP_TO_SMOOI(mth->tmpr_count); + nargs = HCL_OOP_TO_SMOOI(mth->tmpr_nargs); + + HCL_ASSERT (ntmprs >= 0); + HCL_ASSERT (nargs <= ntmprs); + + hcl_pushtmp (hcl, (hcl_oop_t*)&mth); + ctx = (hcl_oop_context_t)make_context (hcl, ntmprs); + hcl_poptmp (hcl); + if (!ctx) return -1; + + ctx->sender = hcl->active_context; + ctx->ip = HCL_SMOOI_TO_OOP(0); + /* ctx->sp will be set further down */ + + /* A context is compose of a fixed part and a variable part. + * the variable part hold temporary varibles including arguments. + * + * Assuming a method context with 2 arguments and 3 local temporary + * variables, the context will look like this. + * +---------------------+ + * | fixed part | + * | | + * | | + * | | + * +---------------------+ + * | tmp1 (arg1) | slot[0] + * | tmp2 (arg2) | slot[1] + * | tmp3 | slot[2] + * | tmp4 | slot[3] + * | tmp5 | slot[4] + * +---------------------+ + */ + + ctx->ntmprs = HCL_SMOOI_TO_OOP(ntmprs); + ctx->method_or_nargs = (hcl_oop_t)mth; + /* the 'home' field of a method context is always hcl->_nil. + ctx->home = hcl->_nil;*/ + ctx->origin = ctx; /* point to self */ + + /* + * Assume this message sending expression: + * obj1 do: #this with: #that with: #it + * + * It would be compiled to these logical byte-code sequences shown below: + * push obj1 + * push #this + * push #that + * push #it + * send #do:with: + * + * After three pushes, the stack looks like this. + * + * | #it | <- sp + * | #that | sp - 1 + * | #this | sp - 2 + * | obj1 | sp - nargs + * + * Since the number of arguments is 3, stack[sp - 3] points to + * the receiver. When the stack is empty, sp is -1. + */ + for (i = nargs; i > 0; ) + { + /* copy argument */ + ctx->slot[--i] = HCL_STACK_GETTOP (hcl); + HCL_STACK_POP (hcl); + } + /* copy receiver */ + ctx->receiver_or_source = HCL_STACK_GETTOP (hcl); + HCL_STACK_POP (hcl); + + HCL_ASSERT (hcl->sp >= -1); + + /* the stack pointer in a context is a stack pointer of a process + * before it is activated. this stack pointer is stored to the context + * so that it is used to restore the process stack pointer upon returning + * from a method context. */ + ctx->sp = HCL_SMOOI_TO_OOP(hcl->sp); + + /* switch the active context to the newly instantiated one*/ + SWITCH_ACTIVE_CONTEXT (hcl, ctx); + + return 0; +} + +static int start_initial_process_and_context (hcl_t* hcl) +{ + hcl_oop_context_t ctx; + hcl_oop_process_t proc; + + /* create a fake initial context. */ + ctx = (hcl_oop_context_t)make_context (hcl, 0); /* no temporary variables */ + if (!ctx) return -1; + + /* the initial context starts the life of the entire VM + * and is not really worked on except that it is used to call the + * initial method. so it doesn't really require any extra stack space. */ +/* TODO: verify this theory of mine. */ + hcl->ip = 0; + hcl->sp = -1; + + ctx->ip = HCL_SMOOI_TO_OOP(0); /* point to the beginning */ + ctx->sp = HCL_SMOOI_TO_OOP(-1); /* pointer to -1 below the bottom */ + ctx->origin = ctx; /* point to self */ + /*ctx->method_or_nargs = (hcl_oop_t)mth;*/ /* fake. help SWITCH_ACTIVE_CONTEXT() not fail. */ + ctx->method_or_nargs = HCL_SMOOI_TO_OOP(0); +/* TODO: XXXXX */ + ctx->ntmprs = HCL_SMOOI_TO_OOP(0); + ctx->home = ctx; // is this correct??? +/* END XXXXX */ + + /* [NOTE] + * the receiver field and the sender field of ctx are nils. + * especially, the fact that the sender field is nil is used by + * the main execution loop for breaking out of the loop */ + + HCL_ASSERT (hcl->active_context == HCL_NULL); + + /* hcl_gc() uses hcl->processor when hcl->active_context + * is not NULL. at this poinst, hcl->processor should point to + * an instance of ProcessScheduler. */ + HCL_ASSERT ((hcl_oop_t)hcl->processor != hcl->_nil); + HCL_ASSERT (hcl->processor->tally == HCL_SMOOI_TO_OOP(0)); + + /* start_initial_process() calls the SWITCH_ACTIVE_CONTEXT() macro. + * the macro assumes a non-null value in hcl->active_context. + * let's force set active_context to ctx directly. */ + hcl->active_context = ctx; + + hcl_pushtmp (hcl, (hcl_oop_t*)&ctx); + proc = start_initial_process (hcl, ctx); + hcl_poptmp (hcl); + if (!proc) return -1; + + +#if 0 + HCL_STACK_PUSH (hcl, ass->value); /* push the receiver - the object referenced by 'objname' */ + STORE_ACTIVE_SP (hcl); /* hcl->active_context->sp = HCL_SMOOI_TO_OOP(hcl->sp) */ + + HCL_ASSERT (hcl->processor->active == proc); + HCL_ASSERT (hcl->processor->active->initial_context == ctx); + HCL_ASSERT (hcl->processor->active->current_context == ctx); + HCL_ASSERT (hcl->active_context == ctx); + + /* emulate the message sending */ + return activate_new_method (hcl, mth); +#else + HCL_STACK_PUSH (hcl, (hcl_oop_t)ctx); + STORE_ACTIVE_SP (hcl); /* hcl->active_context->sp = HCL_SMOOI_TO_OOP(hcl->sp) */ + + return activate_context (hcl, 0); +#endif + +} + +/* ------------------------------------------------------------------------- */ + +static int execute (hcl_t* hcl) +{ + hcl_oob_t bcode; + hcl_oow_t b1, b2; + hcl_oop_t return_value; + int unwind_protect; + hcl_oop_context_t unwind_start; + hcl_oop_context_t unwind_stop; + +#if defined(HCL_PROFILE_VM) + hcl_uintmax_t inst_counter = 0; +#endif + + HCL_ASSERT (hcl->active_context != HCL_NULL); + + vm_startup (hcl); + hcl->proc_switched = 0; + + while (1) + { +#if 0 /* XXX */ + if (hcl->sem_heap_count > 0) + { + hcl_ntime_t ft, now; + vm_gettime (hcl, &now); + + do + { + HCL_ASSERT (HCL_OOP_IS_SMOOI(hcl->sem_heap[0]->heap_ftime_sec)); + HCL_ASSERT (HCL_OOP_IS_SMOOI(hcl->sem_heap[0]->heap_ftime_nsec)); + + HCL_INITNTIME (&ft, + HCL_OOP_TO_SMOOI(hcl->sem_heap[0]->heap_ftime_sec), + HCL_OOP_TO_SMOOI(hcl->sem_heap[0]->heap_ftime_nsec) + ); + + if (HCL_CMPNTIME(&ft, (hcl_ntime_t*)&now) <= 0) + { + hcl_oop_process_t proc; + + /* waited long enough. signal the semaphore */ + + proc = signal_semaphore (hcl, hcl->sem_heap[0]); + /* [NOTE] no hcl_pushtmp() on proc. no GC must occur + * in the following line until it's used for + * wake_new_process() below. */ + delete_from_sem_heap (hcl, 0); + + /* if no process is waiting on the semaphore, + * signal_semaphore() returns hcl->_nil. */ + + if (hcl->processor->active == hcl->nil_process && (hcl_oop_t)proc != hcl->_nil) + { + /* this is the only runnable process. + * switch the process to the running state. + * it uses wake_new_process() instead of + * switch_to_process() as there is no running + * process at this moment */ + HCL_ASSERT (proc->state == HCL_SMOOI_TO_OOP(PROC_STATE_RUNNABLE)); + HCL_ASSERT (proc == hcl->processor->runnable_head); + + wake_new_process (hcl, proc); + hcl->proc_switched = 1; + } + } + else if (hcl->processor->active == hcl->nil_process) + { + HCL_SUBNTIME (&ft, &ft, (hcl_ntime_t*)&now); + vm_sleep (hcl, &ft); /* TODO: change this to i/o multiplexer??? */ + vm_gettime (hcl, &now); + } + else + { + break; + } + } + while (hcl->sem_heap_count > 0); + } + + if (hcl->processor->active == hcl->nil_process) + { + /* no more waiting semaphore and no more process */ + HCL_ASSERT (hcl->processor->tally = HCL_SMOOI_TO_OOP(0)); + HCL_LOG0 (hcl, HCL_LOG_IC | HCL_LOG_DEBUG, "No more runnable process\n"); + +#if 0 +if (there is semaphore awaited.... ) +{ +/* DO SOMETHING */ +} +#endif + + break; + } + + while (hcl->sem_list_count > 0) + { + /* handle async signals */ + --hcl->sem_list_count; + signal_semaphore (hcl, hcl->sem_list[hcl->sem_list_count]); + } + /* + if (semaphore heap has pending request) + { + signal them... + }*/ + + /* TODO: implement different process switching scheme - time-slice or clock based??? */ +#if defined(HCL_EXTERNAL_PROCESS_SWITCH) + if (!hcl->proc_switched && hcl->switch_proc) { switch_to_next_runnable_process (hcl); } + hcl->switch_proc = 0; +#else + if (!hcl->proc_switched) { switch_to_next_runnable_process (hcl); } +#endif + + hcl->proc_switched = 0; +#else + /* TODO: XXX this part is temporary. use if 0 part */ + if (hcl->processor->active == hcl->nil_process) + { + /* no more waiting semaphore and no more process */ + HCL_ASSERT (hcl->processor->tally = HCL_SMOOI_TO_OOP(0)); + HCL_LOG0 (hcl, HCL_LOG_IC | HCL_LOG_DEBUG, "No more runnable process\n"); + break; + } +#endif /* END XXX */ + + FETCH_BYTE_CODE_TO (hcl, bcode); + /*while (bcode == HCL_CODE_NOOP) FETCH_BYTE_CODE_TO (hcl, bcode);*/ + +#if defined(HCL_PROFILE_VM) + inst_counter++; +#endif + + switch (bcode) + { + /* ------------------------------------------------- */ + +#if 0 + case BCODE_PUSH_INSTVAR_X: + FETCH_PARAM_CODE_TO (hcl, b1); + goto push_instvar; + case BCODE_PUSH_INSTVAR_0: + case BCODE_PUSH_INSTVAR_1: + case BCODE_PUSH_INSTVAR_2: + case BCODE_PUSH_INSTVAR_3: + case BCODE_PUSH_INSTVAR_4: + case BCODE_PUSH_INSTVAR_5: + case BCODE_PUSH_INSTVAR_6: + case BCODE_PUSH_INSTVAR_7: + b1 = bcode & 0x7; /* low 3 bits */ + push_instvar: + LOG_INST_1 (hcl, "push_instvar %zu", b1); + HCL_ASSERT (HCL_OBJ_GET_FLAGS_TYPE(hcl->active_context->origin->receiver_or_source) == HCL_OBJ_TYPE_OOP); + HCL_STACK_PUSH (hcl, ((hcl_oop_oop_t)hcl->active_context->origin->receiver_or_source)->slot[b1]); + break; + + /* ------------------------------------------------- */ + + case BCODE_STORE_INTO_INSTVAR_X: + FETCH_PARAM_CODE_TO (hcl, b1); + goto store_instvar; + case BCODE_STORE_INTO_INSTVAR_0: + case BCODE_STORE_INTO_INSTVAR_1: + case BCODE_STORE_INTO_INSTVAR_2: + case BCODE_STORE_INTO_INSTVAR_3: + case BCODE_STORE_INTO_INSTVAR_4: + case BCODE_STORE_INTO_INSTVAR_5: + case BCODE_STORE_INTO_INSTVAR_6: + case BCODE_STORE_INTO_INSTVAR_7: + b1 = bcode & 0x7; /* low 3 bits */ + store_instvar: + LOG_INST_1 (hcl, "store_into_instvar %zu", b1); + HCL_ASSERT (HCL_OBJ_GET_FLAGS_TYPE(hcl->active_context->receiver_or_source) == HCL_OBJ_TYPE_OOP); + ((hcl_oop_oop_t)hcl->active_context->origin->receiver_or_source)->slot[b1] = HCL_STACK_GETTOP(hcl); + break; + + /* ------------------------------------------------- */ + case BCODE_POP_INTO_INSTVAR_X: + FETCH_PARAM_CODE_TO (hcl, b1); + goto pop_into_instvar; + case BCODE_POP_INTO_INSTVAR_0: + case BCODE_POP_INTO_INSTVAR_1: + case BCODE_POP_INTO_INSTVAR_2: + case BCODE_POP_INTO_INSTVAR_3: + case BCODE_POP_INTO_INSTVAR_4: + case BCODE_POP_INTO_INSTVAR_5: + case BCODE_POP_INTO_INSTVAR_6: + case BCODE_POP_INTO_INSTVAR_7: + b1 = bcode & 0x7; /* low 3 bits */ + pop_into_instvar: + LOG_INST_1 (hcl, "pop_into_instvar %zu", b1); + HCL_ASSERT (HCL_OBJ_GET_FLAGS_TYPE(hcl->active_context->receiver_or_source) == HCL_OBJ_TYPE_OOP); + ((hcl_oop_oop_t)hcl->active_context->origin->receiver_or_source)->slot[b1] = HCL_STACK_GETTOP(hcl); + HCL_STACK_POP (hcl); + break; +#endif + + /* ------------------------------------------------- */ + case HCL_CODE_PUSH_TEMPVAR_X: + case HCL_CODE_STORE_INTO_TEMPVAR_X: + case BCODE_POP_INTO_TEMPVAR_X: + FETCH_PARAM_CODE_TO (hcl, b1); + goto handle_tempvar; + + case HCL_CODE_PUSH_TEMPVAR_0: + case HCL_CODE_PUSH_TEMPVAR_1: + case HCL_CODE_PUSH_TEMPVAR_2: + case HCL_CODE_PUSH_TEMPVAR_3: + case HCL_CODE_PUSH_TEMPVAR_4: + case HCL_CODE_PUSH_TEMPVAR_5: + case HCL_CODE_PUSH_TEMPVAR_6: + case HCL_CODE_PUSH_TEMPVAR_7: + case HCL_CODE_STORE_INTO_TEMPVAR_0: + case HCL_CODE_STORE_INTO_TEMPVAR_1: + case HCL_CODE_STORE_INTO_TEMPVAR_2: + case HCL_CODE_STORE_INTO_TEMPVAR_3: + case HCL_CODE_STORE_INTO_TEMPVAR_4: + case HCL_CODE_STORE_INTO_TEMPVAR_5: + case HCL_CODE_STORE_INTO_TEMPVAR_6: + case HCL_CODE_STORE_INTO_TEMPVAR_7: + case BCODE_POP_INTO_TEMPVAR_0: + case BCODE_POP_INTO_TEMPVAR_1: + case BCODE_POP_INTO_TEMPVAR_2: + case BCODE_POP_INTO_TEMPVAR_3: + case BCODE_POP_INTO_TEMPVAR_4: + case BCODE_POP_INTO_TEMPVAR_5: + case BCODE_POP_INTO_TEMPVAR_6: + case BCODE_POP_INTO_TEMPVAR_7: + { + hcl_oop_context_t ctx; + hcl_ooi_t bx; + + b1 = bcode & 0x7; /* low 3 bits */ + handle_tempvar: + + #if defined(HCL_USE_CTXTEMPVAR) + /* when CTXTEMPVAR inststructions are used, the above + * instructions are used only for temporary access + * outside a block. i can assume that the temporary + * variable index is pointing to one of temporaries + * in the relevant method context */ + ctx = hcl->active_context->origin; + bx = b1; + HCL_ASSERT (HCL_IS_CONTEXT(hcl, ctx)); + #else + /* otherwise, the index may point to a temporaries + * declared inside a block */ + + if (hcl->active_context->home != hcl->_nil) + { + /* this code assumes that the method context and + * the block context place some key fields in the + * same offset. such fields include 'home', 'ntmprs' */ + hcl_oop_t home; + hcl_ooi_t home_ntmprs; + + ctx = hcl->active_context; + home = ctx->home; + + do + { + /* ntmprs contains the number of defined temporaries + * including those defined in the home context */ + home_ntmprs = HCL_OOP_TO_SMOOI(((hcl_oop_context_t)home)->ntmprs); + if (b1 >= home_ntmprs) break; + + ctx = (hcl_oop_context_t)home; + home = ((hcl_oop_context_t)home)->home; + if (home == hcl->_nil) + { + home_ntmprs = 0; + break; + } + } + while (1); + + /* bx is the actual index within the actual context + * containing the temporary */ + bx = b1 - home_ntmprs; + } + else + { + ctx = hcl->active_context; + bx = b1; + } + #endif + + if ((bcode >> 4) & 1) + { + /* push - bit 4 on */ + LOG_INST_1 (hcl, "push_tempvar %zu", b1); + HCL_STACK_PUSH (hcl, ctx->slot[bx]); + } + else + { + /* store or pop - bit 5 off */ + ctx->slot[bx] = HCL_STACK_GETTOP(hcl); + + if ((bcode >> 3) & 1) + { + /* pop - bit 3 on */ + LOG_INST_1 (hcl, "pop_into_tempvar %zu", b1); + HCL_STACK_POP (hcl); + } + else + { + LOG_INST_1 (hcl, "store_into_tempvar %zu", b1); + } + } + + break; + } + + /* ------------------------------------------------- */ + case HCL_CODE_PUSH_LITERAL_X2: + FETCH_PARAM_CODE_TO (hcl, b1); + FETCH_PARAM_CODE_TO (hcl, b2); + #if (HCL_BCODE_LONG_PARAM_SIZE == 2) + b1 = (b1 << 16) | b2; + #else + b1 = (b1 << 8) | b2; + #endif + goto push_literal; + + case HCL_CODE_PUSH_LITERAL_X: + FETCH_PARAM_CODE_TO (hcl, b1); + goto push_literal; + + case HCL_CODE_PUSH_LITERAL_0: + case HCL_CODE_PUSH_LITERAL_1: + case HCL_CODE_PUSH_LITERAL_2: + case HCL_CODE_PUSH_LITERAL_3: + case HCL_CODE_PUSH_LITERAL_4: + case HCL_CODE_PUSH_LITERAL_5: + case HCL_CODE_PUSH_LITERAL_6: + case HCL_CODE_PUSH_LITERAL_7: + b1 = bcode & 0x7; /* low 3 bits */ + push_literal: + LOG_INST_1 (hcl, "push_literal @%zu", b1); + HCL_STACK_PUSH (hcl, hcl->code.lit.arr->slot[b1]); + break; + + /* ------------------------------------------------- */ + case HCL_CODE_PUSH_OBJECT_X: + case HCL_CODE_STORE_INTO_OBJECT_X: + case BCODE_POP_INTO_OBJECT_X: + FETCH_PARAM_CODE_TO (hcl, b1); + goto handle_object; + + case HCL_CODE_PUSH_OBJECT_0: + case HCL_CODE_PUSH_OBJECT_1: + case HCL_CODE_PUSH_OBJECT_2: + case HCL_CODE_PUSH_OBJECT_3: + case HCL_CODE_STORE_INTO_OBJECT_0: + case HCL_CODE_STORE_INTO_OBJECT_1: + case HCL_CODE_STORE_INTO_OBJECT_2: + case HCL_CODE_STORE_INTO_OBJECT_3: + case BCODE_POP_INTO_OBJECT_0: + case BCODE_POP_INTO_OBJECT_1: + case BCODE_POP_INTO_OBJECT_2: + case BCODE_POP_INTO_OBJECT_3: + { + hcl_oop_cons_t ass; + + b1 = bcode & 0x3; /* low 2 bits */ + handle_object: + ass = (hcl_oop_cons_t)hcl->code.lit.arr->slot[b1]; + HCL_ASSERT (HCL_IS_CONS(hcl, ass)); + + if ((bcode >> 3) & 1) + { + /* store or pop */ + ass->cdr = HCL_STACK_GETTOP(hcl); + + if ((bcode >> 2) & 1) + { + /* pop */ + LOG_INST_1 (hcl, "pop_into_object @%zu", b1); + HCL_STACK_POP (hcl); + } + else + { + LOG_INST_1 (hcl, "store_into_object @%zu", b1); + } + } + else + { + /* push */ + LOG_INST_1 (hcl, "push_object @%zu", b1); + HCL_STACK_PUSH (hcl, ass->cdr); + } + break; + } + + /* -------------------------------------------------------- */ + + case HCL_CODE_JUMP_FORWARD_X: + FETCH_PARAM_CODE_TO (hcl, b1); + LOG_INST_1 (hcl, "jump_forward %zu", b1); + hcl->ip += b1; + break; + + case HCL_CODE_JUMP_FORWARD_0: + case HCL_CODE_JUMP_FORWARD_1: + case HCL_CODE_JUMP_FORWARD_2: + case HCL_CODE_JUMP_FORWARD_3: + LOG_INST_1 (hcl, "jump_forward %zu", (hcl_oow_t)(bcode & 0x3)); + hcl->ip += (bcode & 0x3); /* low 2 bits */ + break; + + case HCL_CODE_JUMP_BACKWARD_X: + FETCH_PARAM_CODE_TO (hcl, b1); + LOG_INST_1 (hcl, "jump_backward %zu", b1); + hcl->ip += b1; + break; + + case HCL_CODE_JUMP_BACKWARD_0: + case HCL_CODE_JUMP_BACKWARD_1: + case HCL_CODE_JUMP_BACKWARD_2: + case HCL_CODE_JUMP_BACKWARD_3: + LOG_INST_1 (hcl, "jump_backward %zu", (hcl_oow_t)(bcode & 0x3)); + hcl->ip -= (bcode & 0x3); /* low 2 bits */ + break; + + case BCODE_JUMP_IF_TRUE_X: + case BCODE_JUMP_IF_FALSE_X: + case BCODE_JUMP_IF_TRUE_0: + case BCODE_JUMP_IF_TRUE_1: + case BCODE_JUMP_IF_TRUE_2: + case BCODE_JUMP_IF_TRUE_3: + case BCODE_JUMP_IF_FALSE_0: + case BCODE_JUMP_IF_FALSE_1: + case BCODE_JUMP_IF_FALSE_2: + case BCODE_JUMP_IF_FALSE_3: +HCL_LOG0 (hcl, HCL_LOG_IC | HCL_LOG_FATAL, "<<<<<<<<<<<<<< JUMP NOT IMPLEMENTED YET >>>>>>>>>>>>\n"); +hcl->errnum = HCL_ENOIMPL; +return -1; + + case HCL_CODE_JUMP2_FORWARD: + FETCH_PARAM_CODE_TO (hcl, b1); + LOG_INST_1 (hcl, "jump2_forward %zu", b1); + hcl->ip += MAX_CODE_JUMP + b1; + break; + + case HCL_CODE_JUMP2_BACKWARD: + FETCH_PARAM_CODE_TO (hcl, b1); + LOG_INST_1 (hcl, "jump2_backward %zu", b1); + hcl->ip -= MAX_CODE_JUMP + b1; + break; + + /* -------------------------------------------------------- */ + + case HCL_CODE_CALL_X: + FETCH_PARAM_CODE_TO (hcl, b1); + goto handle_call; + case HCL_CODE_CALL_0: + case HCL_CODE_CALL_1: + case HCL_CODE_CALL_2: + case HCL_CODE_CALL_3: + handle_call: + b1 = bcode & 0x3; /* low 2 bits */ + LOG_INST_1 (hcl, "call %zu", b1); + /* TODO: CALL */ + break; + + /* -------------------------------------------------------- */ + + case HCL_CODE_PUSH_CTXTEMPVAR_X: + case HCL_CODE_STORE_INTO_CTXTEMPVAR_X: + case BCODE_POP_INTO_CTXTEMPVAR_X: + FETCH_PARAM_CODE_TO (hcl, b1); + FETCH_PARAM_CODE_TO (hcl, b2); + goto handle_ctxtempvar; + case HCL_CODE_PUSH_CTXTEMPVAR_0: + case HCL_CODE_PUSH_CTXTEMPVAR_1: + case HCL_CODE_PUSH_CTXTEMPVAR_2: + case HCL_CODE_PUSH_CTXTEMPVAR_3: + case HCL_CODE_STORE_INTO_CTXTEMPVAR_0: + case HCL_CODE_STORE_INTO_CTXTEMPVAR_1: + case HCL_CODE_STORE_INTO_CTXTEMPVAR_2: + case HCL_CODE_STORE_INTO_CTXTEMPVAR_3: + case BCODE_POP_INTO_CTXTEMPVAR_0: + case BCODE_POP_INTO_CTXTEMPVAR_1: + case BCODE_POP_INTO_CTXTEMPVAR_2: + case BCODE_POP_INTO_CTXTEMPVAR_3: + { + hcl_ooi_t i; + hcl_oop_context_t ctx; + + b1 = bcode & 0x3; /* low 2 bits */ + FETCH_BYTE_CODE_TO (hcl, b2); + + handle_ctxtempvar: + + ctx = hcl->active_context; + HCL_ASSERT ((hcl_oop_t)ctx != hcl->_nil); + for (i = 0; i < b1; i++) + { + ctx = (hcl_oop_context_t)ctx->home; + } + + if ((bcode >> 3) & 1) + { + /* store or pop */ + ctx->slot[b2] = HCL_STACK_GETTOP(hcl); + + if ((bcode >> 2) & 1) + { + /* pop */ + HCL_STACK_POP (hcl); + LOG_INST_2 (hcl, "pop_into_ctxtempvar %zu %zu", b1, b2); + } + else + { + LOG_INST_2 (hcl, "store_into_ctxtempvar %zu %zu", b1, b2); + } + } + else + { + /* push */ + HCL_STACK_PUSH (hcl, ctx->slot[b2]); + LOG_INST_2 (hcl, "push_ctxtempvar %zu %zu", b1, b2); + } + + break; + } + /* -------------------------------------------------------- */ + + case BCODE_PUSH_OBJVAR_X: + case BCODE_STORE_INTO_OBJVAR_X: + case BCODE_POP_INTO_OBJVAR_X: + FETCH_PARAM_CODE_TO (hcl, b1); + FETCH_PARAM_CODE_TO (hcl, b2); + goto handle_objvar; + + case BCODE_PUSH_OBJVAR_0: + case BCODE_PUSH_OBJVAR_1: + case BCODE_PUSH_OBJVAR_2: + case BCODE_PUSH_OBJVAR_3: + case BCODE_STORE_INTO_OBJVAR_0: + case BCODE_STORE_INTO_OBJVAR_1: + case BCODE_STORE_INTO_OBJVAR_2: + case BCODE_STORE_INTO_OBJVAR_3: + case BCODE_POP_INTO_OBJVAR_0: + case BCODE_POP_INTO_OBJVAR_1: + case BCODE_POP_INTO_OBJVAR_2: + case BCODE_POP_INTO_OBJVAR_3: + { + hcl_oop_oop_t t; + + /* b1 -> variable index to the object indicated by b2. + * b2 -> object index stored in the literal frame. */ + b1 = bcode & 0x3; /* low 2 bits */ + FETCH_BYTE_CODE_TO (hcl, b2); + + handle_objvar: + t = (hcl_oop_oop_t)hcl->code.lit.arr->slot[b2]; + HCL_ASSERT (HCL_OBJ_GET_FLAGS_TYPE(t) == HCL_OBJ_TYPE_OOP); + HCL_ASSERT (b1 < HCL_OBJ_GET_SIZE(t)); + + if ((bcode >> 3) & 1) + { + /* store or pop */ + + t->slot[b1] = HCL_STACK_GETTOP(hcl); + + if ((bcode >> 2) & 1) + { + /* pop */ + HCL_STACK_POP (hcl); + LOG_INST_2 (hcl, "pop_into_objvar %zu %zu", b1, b2); + } + else + { + LOG_INST_2 (hcl, "store_into_objvar %zu %zu", b1, b2); + } + } + else + { + /* push */ + LOG_INST_2 (hcl, "push_objvar %zu %zu", b1, b2); + HCL_STACK_PUSH (hcl, t->slot[b1]); + } + break; + } + + /* -------------------------------------------------------- */ +#if 0 + case BCODE_SEND_MESSAGE_X: + case BCODE_SEND_MESSAGE_TO_SUPER_X: + /* b1 -> number of arguments + * b2 -> selector index stored in the literal frame */ + FETCH_PARAM_CODE_TO (hcl, b1); + FETCH_PARAM_CODE_TO (hcl, b2); + goto handle_send_message; + + case BCODE_SEND_MESSAGE_0: + case BCODE_SEND_MESSAGE_1: + case BCODE_SEND_MESSAGE_2: + case BCODE_SEND_MESSAGE_3: + case BCODE_SEND_MESSAGE_TO_SUPER_0: + case BCODE_SEND_MESSAGE_TO_SUPER_1: + case BCODE_SEND_MESSAGE_TO_SUPER_2: + case BCODE_SEND_MESSAGE_TO_SUPER_3: + { + hcl_oop_char_t selector; + + b1 = bcode & 0x3; /* low 2 bits */ + FETCH_BYTE_CODE_TO (hcl, b2); + + handle_send_message: + /* get the selector from the literal frame */ + selector = (hcl_oop_char_t)hcl->active_method->slot[b2]; + + LOG_INST_3 (hcl, "send_message%hs %zu @%zu", (((bcode >> 2) & 1)? "_to_super": ""), b1, b2); + + if (send_message (hcl, selector, ((bcode >> 2) & 1), b1) <= -1) goto oops; + break; /* CMD_SEND_MESSAGE */ + } +#endif + /* -------------------------------------------------------- */ + + case BCODE_PUSH_RECEIVER: + LOG_INST_0 (hcl, "push_receiver"); + HCL_STACK_PUSH (hcl, hcl->active_context->origin->receiver_or_source); + break; + + case HCL_CODE_PUSH_NIL: + LOG_INST_0 (hcl, "push_nil"); + HCL_STACK_PUSH (hcl, hcl->_nil); + break; + + case HCL_CODE_PUSH_TRUE: + LOG_INST_0 (hcl, "push_true"); + HCL_STACK_PUSH (hcl, hcl->_true); + break; + + case HCL_CODE_PUSH_FALSE: + LOG_INST_0 (hcl, "push_false"); + HCL_STACK_PUSH (hcl, hcl->_false); + break; + + case BCODE_PUSH_CONTEXT: + LOG_INST_0 (hcl, "push_context"); + HCL_STACK_PUSH (hcl, (hcl_oop_t)hcl->active_context); + break; + + case BCODE_PUSH_PROCESS: + LOG_INST_0 (hcl, "push_process"); + HCL_STACK_PUSH (hcl, (hcl_oop_t)hcl->processor->active); + break; + + case HCL_CODE_PUSH_NEGONE: + LOG_INST_0 (hcl, "push_negone"); + HCL_STACK_PUSH (hcl, HCL_SMOOI_TO_OOP(-1)); + break; + + case HCL_CODE_PUSH_ZERO: + LOG_INST_0 (hcl, "push_zero"); + HCL_STACK_PUSH (hcl, HCL_SMOOI_TO_OOP(0)); + break; + + case HCL_CODE_PUSH_ONE: + LOG_INST_0 (hcl, "push_one"); + HCL_STACK_PUSH (hcl, HCL_SMOOI_TO_OOP(1)); + break; + + case HCL_CODE_PUSH_TWO: + LOG_INST_0 (hcl, "push_two"); + HCL_STACK_PUSH (hcl, HCL_SMOOI_TO_OOP(2)); + break; + + case HCL_CODE_PUSH_INTLIT: + FETCH_PARAM_CODE_TO (hcl, b1); + LOG_INST_1 (hcl, "push_intlit %zu", b1); + HCL_STACK_PUSH (hcl, HCL_SMOOI_TO_OOP(b1)); + break; + + case HCL_CODE_PUSH_NEGINTLIT: + { + hcl_ooi_t num; + FETCH_PARAM_CODE_TO (hcl, b1); + num = b1; + LOG_INST_1 (hcl, "push_negintlit %zu", b1); + HCL_STACK_PUSH (hcl, HCL_SMOOI_TO_OOP(-num)); + break; + } + + case HCL_CODE_PUSH_CHARLIT: + FETCH_PARAM_CODE_TO (hcl, b1); + LOG_INST_1 (hcl, "push_charlit %zu", b1); + HCL_STACK_PUSH (hcl, HCL_CHAR_TO_OOP(b1)); + break; + /* -------------------------------------------------------- */ + + case BCODE_DUP_STACKTOP: + { + hcl_oop_t t; + LOG_INST_0 (hcl, "dup_stacktop"); + HCL_ASSERT (!HCL_STACK_ISEMPTY(hcl)); + t = HCL_STACK_GETTOP(hcl); + HCL_STACK_PUSH (hcl, t); + break; + } + + case HCL_CODE_POP_STACKTOP: + LOG_INST_0 (hcl, "pop_stacktop"); + HCL_ASSERT (!HCL_STACK_ISEMPTY(hcl)); + HCL_STACK_POP (hcl); + break; + + case BCODE_RETURN_STACKTOP: + LOG_INST_0 (hcl, "return_stacktop"); + return_value = HCL_STACK_GETTOP(hcl); + HCL_STACK_POP (hcl); + goto handle_return; + + case BCODE_RETURN_RECEIVER: + LOG_INST_0 (hcl, "return_receiver"); + return_value = hcl->active_context->origin->receiver_or_source; + + handle_return: + if (hcl->active_context->origin == hcl->processor->active->initial_context->origin) + { + /* method return from a processified block + * + * #method(#class) main + * { + * [^100] newProcess resume. + * '1111' dump. + * '1111' dump. + * '1111' dump. + * ^300. + * } + * + * ^100 doesn't terminate a main process as the block + * has been processified. on the other hand, ^100 + * in the following program causes main to exit. + * + * #method(#class) main + * { + * [^100] value. + * '1111' dump. + * '1111' dump. + * '1111' dump. + * ^300. + * } + */ + +// HCL_ASSERT (HCL_CLASSOF(hcl, hcl->active_context) == hcl->_block_context); +// HCL_ASSERT (HCL_CLASSOF(hcl, hcl->processor->active->initial_context) == hcl->_block_context); + + /* decrement the instruction pointer back to the return instruction. + * even if the context is reentered, it will just return. + *hcl->ip--;*/ + + terminate_process (hcl, hcl->processor->active); + } + else + { + unwind_protect = 0; + + /* set the instruction pointer to an invalid value. + * this is stored into the current method context + * before context switching and marks a dead context */ + if (hcl->active_context->origin == hcl->active_context) + { + /* returning from a method */ +// HCL_ASSERT (HCL_CLASSOF(hcl, hcl->active_context) == hcl->_method_context); + hcl->ip = -1; + } + else + { + hcl_oop_context_t ctx; + + /* method return from within a block(including a non-local return) */ +// HCL_ASSERT (HCL_CLASSOF(hcl, hcl->active_context) == hcl->_block_context); + + ctx = hcl->active_context; + while ((hcl_oop_t)ctx != hcl->_nil) + { + #if 0 +// /* TODO: XXXXXXXXXXXXXX for STACK UNWINDING... */ + if (HCL_CLASSOF(hcl, ctx) == hcl->_method_context) + { + hcl_ooi_t preamble; + preamble = HCL_OOP_TO_SMOOI(((hcl_oop_method_t)ctx->method_or_nargs)->preamble); + if (HCL_METHOD_GET_PREAMBLE_CODE(preamble) == HCL_METHOD_PREAMBLE_ENSURE) + { + if (!unwind_protect) + { + unwind_protect = 1; + unwind_start = ctx; + } + unwind_stop = ctx; + } + } + #endif + if (ctx == hcl->active_context->origin) goto non_local_return_ok; + ctx = ctx->sender; + } + + /* cannot return from a method that has returned already */ +// HCL_ASSERT (HCL_CLASSOF(hcl, hcl->active_context->origin) == hcl->_method_context); + HCL_ASSERT (hcl->active_context->origin->ip == HCL_SMOOI_TO_OOP(-1)); + + HCL_LOG0 (hcl, HCL_LOG_IC | HCL_LOG_ERROR, "Error - cannot return from dead context\n"); + hcl->errnum = HCL_EINTERN; /* TODO: can i make this error catchable at the hcl level? */ + return -1; + + non_local_return_ok: +/*HCL_DEBUG2 (hcl, "NON_LOCAL RETURN OK TO... %p %p\n", hcl->active_context->origin, hcl->active_context->origin->sender);*/ + hcl->active_context->origin->ip = HCL_SMOOI_TO_OOP(-1); + } + +// HCL_ASSERT (HCL_CLASSOF(hcl, hcl->active_context->origin) == hcl->_method_context); + /* restore the stack pointer */ + hcl->sp = HCL_OOP_TO_SMOOI(hcl->active_context->origin->sp); + SWITCH_ACTIVE_CONTEXT (hcl, hcl->active_context->origin->sender); + + if (unwind_protect) + { + static hcl_ooch_t fbm[] = { + 'u', 'n', 'w', 'i', 'n', 'd', 'T', 'o', ':', + 'r', 'e', 't', 'u', 'r', 'n', ':' + }; + + HCL_STACK_PUSH (hcl, (hcl_oop_t)unwind_start); + HCL_STACK_PUSH (hcl, (hcl_oop_t)unwind_stop); + HCL_STACK_PUSH (hcl, (hcl_oop_t)return_value); + + if (send_private_message (hcl, fbm, 16, 0, 2) <= -1) return -1; + } + else + { + /* push the return value to the stack of the new active context */ + HCL_STACK_PUSH (hcl, return_value); + + if (hcl->active_context == hcl->initial_context) + { + /* the new active context is the fake initial context. + * this context can't get executed further. */ + HCL_ASSERT ((hcl_oop_t)hcl->active_context->sender == hcl->_nil); +// HCL_ASSERT (HCL_CLASSOF(hcl, hcl->active_context) == hcl->_method_context); + HCL_ASSERT (hcl->active_context->receiver_or_source == hcl->_nil); + HCL_ASSERT (hcl->active_context == hcl->processor->active->initial_context); + HCL_ASSERT (hcl->active_context->origin == hcl->processor->active->initial_context->origin); + HCL_ASSERT (hcl->active_context->origin == hcl->active_context); + + /* NOTE: this condition is true for the processified block context also. + * hcl->active_context->origin == hcl->processor->active->initial_context->origin + * however, the check here is done after context switching and the + * processified block check has been done against the context before switching */ + + /* the stack contains the final return value so the stack pointer must be 0. */ + HCL_ASSERT (hcl->sp == 0); + + if (hcl->option.trait & HCL_AWAIT_PROCS) + terminate_process (hcl, hcl->processor->active); + else + goto done; + + /* TODO: store the return value to the VM register. + * the caller to hcl_execute() can fetch it to return it to the system */ + } + } + } + + break; + + case HCL_CODE_RETURN_FROM_BLOCK: + LOG_INST_0 (hcl, "return_from_block"); + +// HCL_ASSERT(HCL_CLASSOF(hcl, hcl->active_context) == hcl->_block_context); + + if (hcl->active_context == hcl->processor->active->initial_context) + { + /* the active context to return from is an initial context of + * the active process. this process must have been created + * over a block using the newProcess method. let's terminate + * the process. */ + + HCL_ASSERT ((hcl_oop_t)hcl->active_context->sender == hcl->_nil); + terminate_process (hcl, hcl->processor->active); + } + else + { + /* it is a normal block return as the active block context + * is not the initial context of a process */ + + /* the process stack is shared. the return value + * doesn't need to get moved. */ + //XXX SWITCH_ACTIVE_CONTEXT (hcl, (hcl_oop_context_t)hcl->active_context->sender); + if (hcl->active_context->sender == hcl->processor->active->initial_context) + { + terminate_process (hcl, hcl->processor->active); + } + else + { + SWITCH_ACTIVE_CONTEXT (hcl, (hcl_oop_context_t)hcl->active_context->sender); + } + } + + break; + + case HCL_CODE_MAKE_BLOCK: + { + hcl_oop_context_t blkctx; + + /* b1 - number of block arguments + * b2 - number of block temporaries */ + FETCH_PARAM_CODE_TO (hcl, b1); + FETCH_PARAM_CODE_TO (hcl, b2); + + LOG_INST_2 (hcl, "make_block %zu %zu", b1, b2); + + HCL_ASSERT (b1 >= 0); + HCL_ASSERT (b2 >= b1); + + /* the block context object created here is used as a base + * object for block context activation. prim_block_value() + * clones a block context and activates the cloned context. + * this base block context is created with no stack for + * this reason */ + //blkctx = (hcl_oop_context_t)hcl_instantiate (hcl, hcl->_block_context, HCL_NULL, 0); + blkctx = (hcl_oop_context_t)make_context (hcl, 0); + if (!blkctx) return -1; + + /* the long forward jump instruction has the format of + * 11000100 KKKKKKKK or 11000100 KKKKKKKK KKKKKKKK + * depending on HCL_BCODE_LONG_PARAM_SIZE. change 'ip' to point to + * the instruction after the jump. */ + blkctx->ip = HCL_SMOOI_TO_OOP(hcl->ip + HCL_BCODE_LONG_PARAM_SIZE + 1); + /* stack pointer below the bottom. this base block context + * has an empty stack anyway. */ + blkctx->sp = HCL_SMOOI_TO_OOP(-1); + /* the number of arguments for a block context is local to the block */ + blkctx->method_or_nargs = HCL_SMOOI_TO_OOP(b1); + /* the number of temporaries here is an accumulated count including + * the number of temporaries of a home context */ + blkctx->ntmprs = HCL_SMOOI_TO_OOP(b2); + + /* set the home context where it's defined */ + blkctx->home = (hcl_oop_t)hcl->active_context; + /* no source for a base block context. */ + blkctx->receiver_or_source = hcl->_nil; + + blkctx->origin = hcl->active_context->origin; + + /* push the new block context to the stack of the active context */ + HCL_STACK_PUSH (hcl, (hcl_oop_t)blkctx); + break; + } + + case BCODE_SEND_BLOCK_COPY: + { + hcl_ooi_t nargs, ntmprs; + hcl_oop_context_t rctx; + hcl_oop_context_t blkctx; + + LOG_INST_0 (hcl, "send_block_copy"); + + /* it emulates thisContext blockCopy: nargs ofTmprCount: ntmprs */ + HCL_ASSERT (hcl->sp >= 2); + + HCL_ASSERT (HCL_CLASSOF(hcl, HCL_STACK_GETTOP(hcl)) == hcl->_small_integer); + ntmprs = HCL_OOP_TO_SMOOI(HCL_STACK_GETTOP(hcl)); + HCL_STACK_POP (hcl); + + HCL_ASSERT (HCL_CLASSOF(hcl, HCL_STACK_GETTOP(hcl)) == hcl->_small_integer); + nargs = HCL_OOP_TO_SMOOI(HCL_STACK_GETTOP(hcl)); + HCL_STACK_POP (hcl); + + HCL_ASSERT (nargs >= 0); + HCL_ASSERT (ntmprs >= nargs); + + /* the block context object created here is used + * as a base object for block context activation. + * prim_block_value() clones a block + * context and activates the cloned context. + * this base block context is created with no + * stack for this reason. */ + //blkctx = (hcl_oop_context_t)hcl_instantiate (hcl, hcl->_block_context, HCL_NULL, 0); + blkctx = (hcl_oop_context_t)make_context (hcl, 0); + if (!blkctx) return -1; + + /* get the receiver to the block copy message after block context instantiation + * not to get affected by potential GC */ + rctx = (hcl_oop_context_t)HCL_STACK_GETTOP(hcl); + HCL_ASSERT (rctx == hcl->active_context); + + /* [NOTE] + * blkctx->sender is left to nil. it is set to the + * active context before it gets activated. see + * prim_block_value(). + * + * blkctx->home is set here to the active context. + * it's redundant to have them pushed to the stack + * though it is to emulate the message sending of + * blockCopy:withNtmprs:. BCODE_MAKE_BLOCK has been + * added to replace BCODE_SEND_BLOCK_COPY and pusing + * arguments to the stack. + * + * blkctx->origin is set here by copying the origin + * of the active context. + */ + + /* the extended jump instruction has the format of + * 0000XXXX KKKKKKKK or 0000XXXX KKKKKKKK KKKKKKKK + * depending on HCL_BCODE_LONG_PARAM_SIZE. change 'ip' to point to + * the instruction after the jump. */ + blkctx->ip = HCL_SMOOI_TO_OOP(hcl->ip + HCL_BCODE_LONG_PARAM_SIZE + 1); + blkctx->sp = HCL_SMOOI_TO_OOP(-1); + /* the number of arguments for a block context is local to the block */ + blkctx->method_or_nargs = HCL_SMOOI_TO_OOP(nargs); + /* the number of temporaries here is an accumulated count including + * the number of temporaries of a home context */ + blkctx->ntmprs = HCL_SMOOI_TO_OOP(ntmprs); + + blkctx->home = (hcl_oop_t)rctx; + blkctx->receiver_or_source = hcl->_nil; + + + /* [NOTE] + * the origin of a method context is set to itself + * when it's created. so it's safe to simply copy + * the origin field this way. + */ + blkctx->origin = rctx->origin; + + HCL_STACK_SETTOP (hcl, (hcl_oop_t)blkctx); + break; + } + + case HCL_CODE_NOOP: + /* do nothing */ + LOG_INST_0 (hcl, "noop"); + break; + + + default: + HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_FATAL, "Fatal error - unknown byte code 0x%zx\n", bcode); + hcl->errnum = HCL_EINTERN; + goto oops; + } + } + +done: + vm_cleanup (hcl); +#if defined(HCL_PROFILE_VM) + HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_INFO, "TOTAL_INST_COUTNER = %zu\n", inst_counter); +#endif + return 0; + +oops: + /* TODO: anything to do here? */ + return -1; +} + +int hcl_execute (hcl_t* hcl) +{ + int n; + + HCL_ASSERT (hcl->initial_context == HCL_NULL); + HCL_ASSERT (hcl->active_context == HCL_NULL); + + if (start_initial_process_and_context (hcl) <= -1) return -1; + hcl->initial_context = hcl->processor->active->initial_context; + + n = execute (hcl); + +/* TODO: reset processor fields. set processor->tally to zero. processor->active to nil_process... */ + hcl->initial_context = HCL_NULL; + hcl->active_context = HCL_NULL; + return n; +} diff --git a/lib/gc.c b/lib/gc.c index 61af827..45f446f 100644 --- a/lib/gc.c +++ b/lib/gc.c @@ -285,9 +285,10 @@ void hcl_gc (hcl_t* hcl) if (hcl->active_context) { - /*HCL_ASSERT ((hcl_oop_t)hcl->processor != hcl->_nil); - if ((hcl_oop_t)hcl->processor->active != hcl->_nil)*/ - hcl->processor->active->sp = HCL_SMOOI_TO_OOP(hcl->sp); + HCL_ASSERT ((hcl_oop_t)hcl->processor != hcl->_nil); + HCL_ASSERT ((hcl_oop_t)hcl->processor->active != hcl->_nil); + /* store the stack pointer to the active process */ + hcl->processor->active->sp = HCL_SMOOI_TO_OOP(hcl->sp); /* store the instruction pointer to the active context */ hcl->active_context->ip = HCL_SMOOI_TO_OOP(hcl->ip); @@ -347,10 +348,10 @@ void hcl_gc (hcl_t* hcl) *hcl->tmp_stack[i] = hcl_moveoop (hcl, *hcl->tmp_stack[i]); } + if (hcl->initial_context) + hcl->initial_context = (hcl_oop_context_t)hcl_moveoop (hcl, (hcl_oop_t)hcl->initial_context); if (hcl->active_context) hcl->active_context = (hcl_oop_context_t)hcl_moveoop (hcl, (hcl_oop_t)hcl->active_context); - if (hcl->active_method) - hcl->active_method = (hcl_oop_method_t)hcl_moveoop (hcl, (hcl_oop_t)hcl->active_method); for (cb = hcl->cblist; cb; cb = cb->next) { @@ -385,26 +386,29 @@ void hcl_gc (hcl_t* hcl) hcl->curheap = hcl->newheap; hcl->newheap = tmp; + /* -{ -hcl_oow_t index; -hcl_oop_oop_t buc; -printf ("=== SURVIVING SYMBOLS ===\n"); -buc = (hcl_oop_oop_t) hcl->symtab->slot[HCL_SYMTAB_BUCKET]; -for (index = 0; index < buc->size; index++) -{ - if ((hcl_oop_t)buc->slot[index] != hcl->_nil) + if (hcl->symtab && HCL_LOG_ENABLED(hcl, HCL_LOG_GC | HCL_LOG_DEBUG)) { - const hcl_oop_char_t* p = ((hcl_oop_char_t)buc->slot[index])->slot; - printf ("SYM ["); - while (*p) printf ("%c", *p++); - printf ("]\n"); + hcl_oow_t index; + hcl_oop_oop_t buc; + HCL_LOG0 (hcl, HCL_LOG_GC | HCL_LOG_DEBUG, "--------- SURVIVING SYMBOLS IN GC ----------\n"); + buc = (hcl_oop_oop_t) hcl->symtab->bucket; + for (index = 0; index < HCL_OBJ_GET_SIZE(buc); index++) + { + if ((hcl_oop_t)buc->slot[index] != hcl->_nil) + { + HCL_LOG1 (hcl, HCL_LOG_GC | HCL_LOG_DEBUG, "\t%O\n", buc->slot[index]); + } + } + HCL_LOG0 (hcl, HCL_LOG_GC | HCL_LOG_DEBUG, "--------------------------------------------\n"); } -} -printf ("===========================\n"); -} */ - if (hcl->active_method) SET_ACTIVE_METHOD_CODE (hcl); /* update hcl->active_code */ + +/* TODO: include some gc statstics like number of live objects, gc performance, etc */ + HCL_LOG4 (hcl, HCL_LOG_GC | HCL_LOG_INFO, + "Finished GC curheap base %p ptr %p newheap base %p ptr %p\n", + hcl->curheap->base, hcl->curheap->ptr, hcl->newheap->base, hcl->newheap->ptr); } @@ -496,6 +500,24 @@ int hcl_ignite (hcl_t* hcl) *(hcl_oop_t*)((hcl_uint8_t*)hcl + syminfo[i].offset) = tmp; } + + if (!hcl->nil_process) + { + /* Create a nil process used to simplify nil check in GC. + * only accessible by VM. not exported via the global dictionary. */ + hcl->nil_process = (hcl_oop_process_t)hcl_allocoopobj (hcl, HCL_BRAND_PROCESS, HCL_PROCESS_NAMED_INSTVARS); + if (!hcl->nil_process) return -1; + hcl->nil_process->sp = HCL_SMOOI_TO_OOP(-1); + } + + if (!hcl->processor) + { + hcl->processor = (hcl_oop_process_scheduler_t)hcl_allocoopobj (hcl, HCL_BRAND_PROCESS_SCHEDULER, HCL_PROCESS_SCHEDULER_NAMED_INSTVARS); + if (!hcl->processor) return -1; + hcl->processor->tally = HCL_SMOOI_TO_OOP(0); + hcl->processor->active = hcl->nil_process; + } + if (!hcl->code.bc.arr) { hcl->code.bc.arr = hcl_makengcbytearray (hcl, HCL_NULL, 20000); /* TODO: set a proper intial size */ @@ -504,7 +526,7 @@ int hcl_ignite (hcl_t* hcl) if (!hcl->code.lit.arr) { - hcl->code.lit.arr = hcl_makengcarray (hcl, 20000); /* TOOD: set a proper initial size */ + hcl->code.lit.arr = (hcl_oop_oop_t)hcl_makengcarray (hcl, 20000); /* TOOD: set a proper initial size */ if (!hcl->code.lit.arr) return -1; } diff --git a/lib/hcl-cmn.h b/lib/hcl-cmn.h index bb5d917..9eb1619 100644 --- a/lib/hcl-cmn.h +++ b/lib/hcl-cmn.h @@ -447,7 +447,6 @@ struct hcl_ntime_t #define HCL_ORBITS(type,value,offset,length,bits) \ (value = (((type)(value)) | (((bits) & HCL_LBMASK(type,length)) << (offset)))) - /** * The HCL_BITS_MAX() macros calculates the maximum value that the 'nbits' * bits of an unsigned integer of the given 'type' can hold. diff --git a/lib/hcl-prv.h b/lib/hcl-prv.h index 80648b0..36a63f6 100644 --- a/lib/hcl-prv.h +++ b/lib/hcl-prv.h @@ -52,7 +52,7 @@ /* this is for gc debugging */ /*#define HCL_DEBUG_PROCESSOR*/ #define HCL_DEBUG_GC - +#define HCL_DEBUG_VM_EXEC /* limit the maximum object size such that: * 1. an index to an object field can be represented in a small integer. @@ -377,16 +377,8 @@ struct hcl_compiler_t hcl_oow_t tmprcnt_capa; } blk; /* lambda block */ }; - #endif -#if defined(HCL_USE_OBJECT_TRAILER) - /* let it point to the trailer of the method */ -# define SET_ACTIVE_METHOD_CODE(hcl) ((hcl)->active_code = (hcl_oob_t*)&(hcl)->active_method->slot[HCL_OBJ_GET_SIZE((hcl)->active_method) + 1 - HCL_METHOD_NAMED_INSTVARS]) -#else - /* let it point to the payload of the code byte array */ -# define SET_ACTIVE_METHOD_CODE(hcl) ((hcl)->active_code = (hcl)->active_method->code->slot) -#endif #if defined(HCL_BCODE_LONG_PARAM_SIZE) && (HCL_BCODE_LONG_PARAM_SIZE == 1) # define MAX_CODE_INDEX (0xFFu) @@ -757,6 +749,7 @@ void* hcl_allocbytes ( */ hcl_oop_t hcl_allocoopobj ( hcl_t* hcl, + int brand, hcl_oow_t size ); @@ -771,24 +764,28 @@ hcl_oop_t hcl_allocoopobjwithtrailer ( hcl_oop_t hcl_alloccharobj ( hcl_t* hcl, + int brand, const hcl_ooch_t* ptr, hcl_oow_t len ); hcl_oop_t hcl_allocbyteobj ( - hcl_t* hcl, - const hcl_oob_t* ptr, - hcl_oow_t len + hcl_t* hcl, + int brand, + const hcl_oob_t* ptr, + hcl_oow_t len ); hcl_oop_t hcl_allochalfwordobj ( hcl_t* hcl, + int brand, const hcl_oohw_t* ptr, hcl_oow_t len ); hcl_oop_t hcl_allocwordobj ( hcl_t* hcl, + int brand, const hcl_oow_t* ptr, hcl_oow_t len ); diff --git a/lib/hcl.h b/lib/hcl.h index 2883c33..04034a7 100644 --- a/lib/hcl.h +++ b/lib/hcl.h @@ -53,6 +53,7 @@ enum hcl_errnum_t HCL_ERANGE, /**< range error. overflow and underflow */ HCL_ENOENT, /**< no matching entry */ HCL_EEXIST, /**< duplicate entry */ + HCL_EBCFULL, /**< byte-code full */ HCL_EDFULL, /**< dictionary full */ HCL_EPFULL, /**< processor full */ HCL_ESHFULL, /**< semaphore heap full */ @@ -597,11 +598,11 @@ struct hcl_context_t }; -#define HCL_PROCESS_NAMED_INSTVARS 7 +#define HCL_PROCESS_NAMED_INSTVARS 7 /* TODO: RENAME THIS TO SOMETHING ELSE */ typedef struct hcl_process_t hcl_process_t; typedef struct hcl_process_t* hcl_oop_process_t; -#define HCL_SEMAPHORE_NAMED_INSTVARS 6 +#define HCL_SEMAPHORE_NAMED_INSTVARS 6 /* TODO: RENAME THIS TO SOMETHIGN ELSE */ typedef struct hcl_semaphore_t hcl_semaphore_t; typedef struct hcl_semaphore_t* hcl_oop_semaphore_t; @@ -938,12 +939,13 @@ struct hcl_t hcl_oow_t tmp_count; /* == EXECUTION REGISTERS == */ + hcl_oop_context_t initial_context; /* fake initial context */ hcl_oop_context_t active_context; - hcl_oop_method_t active_method; - hcl_oob_t* active_code; hcl_ooi_t sp; hcl_ooi_t ip; int proc_switched; /* TODO: this is temporary. implement something else to skip immediate context switching */ + int switch_proc; + hcl_ntime_t vm_time_offset; /* == END EXECUTION REGISTERS == */ /* == BIGINT CONVERSION == */ @@ -958,13 +960,13 @@ struct hcl_t { struct { - hcl_oop_t arr; /* byte code array - not part of object memory */ + hcl_oop_byte_t arr; /* byte code array - not part of object memory */ hcl_oow_t len; } bc; struct { - hcl_oop_t arr; /* literal array - not part of object memory */ + hcl_oop_oop_t arr; /* literal array - not part of object memory */ hcl_oow_t len; } lit; } code; @@ -987,6 +989,33 @@ struct hcl_t #endif }; + +/* TODO: stack bound check when pushing */ +#define HCL_STACK_PUSH(hcl,v) \ + do { \ + (hcl)->sp = (hcl)->sp + 1; \ + (hcl)->processor->active->slot[(hcl)->sp] = v; \ + } while (0) + +#define HCL_STACK_GET(hcl,v_sp) ((hcl)->processor->active->slot[v_sp]) +#define HCL_STACK_SET(hcl,v_sp,v_obj) ((hcl)->processor->active->slot[v_sp] = v_obj) + +#define HCL_STACK_GETTOP(hcl) HCL_STACK_GET(hcl, (hcl)->sp) +#define HCL_STACK_SETTOP(hcl,v_obj) HCL_STACK_SET(hcl, (hcl)->sp, v_obj) + +#define HCL_STACK_POP(hcl) ((hcl)->sp = (hcl)->sp - 1) +#define HCL_STACK_POPS(hcl,count) ((hcl)->sp = (hcl)->sp - (count)) +#define HCL_STACK_ISEMPTY(hcl) ((hcl)->sp <= -1) + +#define HCL_STACK_GETARG(hcl,nargs,idx) HCL_STACK_GET(hcl, (hcl)->sp - ((nargs) - (idx) - 1)) +#define HCL_STACK_GETRCV(hcl,nargs) HCL_STACK_GET(hcl, (hcl)->sp - nargs); + +/* you can't access arguments and receiver after this macro. + * also you must not call this macro more than once */ +#define HCL_STACK_SETRET(hcl,nargs,retv) (HCL_STACK_POPS(hcl, nargs), HCL_STACK_SETTOP(hcl, retv)) +#define HCL_STACK_SETRETTORCV(hcl,nargs) (HCL_STACK_POPS(hcl, nargs)) + + /* ========================================================================= * HCL VM LOGGING * ========================================================================= */ @@ -1036,7 +1065,7 @@ typedef enum hcl_log_mask_t hcl_log_mask_t; * ========================================================================= */ enum { - HCL_BRAND_NIL, + HCL_BRAND_NIL = 1, HCL_BRAND_TRUE, HCL_BRAND_FALSE, HCL_BRAND_CHARACTER, @@ -1049,10 +1078,12 @@ enum HCL_BRAND_STRING, HCL_BRAND_SET, - HCL_BRAND_ENVIRONMENT, HCL_BRAND_CFRAME,/* compiler frame */ - HCL_BRAND_PROCESS + HCL_BRAND_CONTEXT, + HCL_BRAND_PROCESS, + HCL_BRAND_PROCESS_SCHEDULER, + HCL_BRAND_SEMAPHORE }; enum @@ -1078,7 +1109,10 @@ typedef struct hcl_cons_t* hcl_oop_cons_t; #define HCL_IS_NIL(hcl,v) (v == (hcl)->_nil) #define HCL_IS_SYMBOL(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SYMBOL) #define HCL_IS_SYMBOL_ARRAY(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SYMBOL_ARRAY) +#define HCL_IS_CONTEXT(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CONTEXT) +#define HCL_IS_PROCESS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PROCESS) #define HCL_IS_CONS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CONS) +#define HCL_IS_ARRAY(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_ARRAY) #define HCL_CONS_CAR(v) (((hcl_cons_t*)(v))->car) #define HCL_CONS_CDR(v) (((hcl_cons_t*)(v))->cdr) @@ -1266,8 +1300,8 @@ HCL_EXPORT void hcl_poptmps ( HCL_EXPORT int hcl_decode ( hcl_t* hcl, - hcl_oow_t start, - hcl_oow_t end + hcl_ooi_t start, + hcl_ooi_t end ); /* Syntax error handling */ @@ -1365,6 +1399,16 @@ HCL_EXPORT hcl_oop_t hcl_makeset ( hcl_oow_t inisize /* initial bucket size */ ); +HCL_EXPORT hcl_oop_t hcl_makeprocess ( + hcl_t* hcl, + hcl_oow_t stksize +); + +HCL_EXPORT hcl_oop_t hcl_makecontext ( + hcl_t* hcl, + hcl_ooi_t ntmprs +); + HCL_EXPORT void hcl_freengcobj ( hcl_t* hcl, diff --git a/lib/main.c b/lib/main.c index bc241cf..da60660 100644 --- a/lib/main.c +++ b/lib/main.c @@ -621,6 +621,13 @@ int main (int argc, char* argv[]) } } +hcl_decode (hcl, 0, hcl->code.bc.len); +HCL_LOG0 (hcl, HCL_LOG_MNEMONIC, "------------------------------------------\n"); +if (hcl_execute (hcl) <= -1) +{ + printf ("ERROR: cannot execute - %d\n", hcl_geterrnum(hcl)); +} + { HCL_LOG0 (hcl, HCL_LOG_MNEMONIC, "------------------------------------------\n"); diff --git a/lib/obj.c b/lib/obj.c index 653bb05..04a5194 100644 --- a/lib/obj.c +++ b/lib/obj.c @@ -46,7 +46,7 @@ void* hcl_allocbytes (hcl_t* hcl, hcl_oow_t size) return ptr; } -hcl_oop_t hcl_allocoopobj (hcl_t* hcl, hcl_oow_t size) +hcl_oop_t hcl_allocoopobj (hcl_t* hcl, int brand, hcl_oow_t size) { hcl_oop_oop_t hdr; hcl_oow_t nbytes, nbytes_aligned; @@ -67,6 +67,7 @@ hcl_oop_t hcl_allocoopobj (hcl_t* hcl, hcl_oow_t size) hdr->_flags = HCL_OBJ_MAKE_FLAGS(HCL_OBJ_TYPE_OOP, HCL_SIZEOF(hcl_oop_t), 0, 0, 0, 0, 0, 0); HCL_OBJ_SET_SIZE (hdr, size); HCL_OBJ_SET_CLASS (hdr, hcl->_nil); + HCL_OBJ_SET_FLAGS_BRAND (hdr, brand); while (size > 0) hdr->slot[--size] = hcl->_nil; @@ -109,7 +110,7 @@ hcl_oop_t hcl_allocoopobjwithtrailer (hcl_t* hcl, hcl_oow_t size, const hcl_oob_ } #endif -static HCL_INLINE hcl_oop_t alloc_numeric_array (hcl_t* hcl, const void* ptr, hcl_oow_t len, hcl_obj_type_t type, hcl_oow_t unit, int extra, int ngc) +static HCL_INLINE hcl_oop_t alloc_numeric_array (hcl_t* hcl, int brand, const void* ptr, hcl_oow_t len, hcl_obj_type_t type, hcl_oow_t unit, int extra, int ngc) { /* allocate a variable object */ @@ -137,6 +138,7 @@ static HCL_INLINE hcl_oop_t alloc_numeric_array (hcl_t* hcl, const void* ptr, hc hdr->_size = len; HCL_OBJ_SET_SIZE (hdr, len); HCL_OBJ_SET_CLASS (hdr, hcl->_nil); + HCL_OBJ_SET_FLAGS_BRAND (hdr, brand); if (ptr) { @@ -153,24 +155,24 @@ static HCL_INLINE hcl_oop_t alloc_numeric_array (hcl_t* hcl, const void* ptr, hc return hdr; } -hcl_oop_t hcl_alloccharobj (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow_t len) +hcl_oop_t hcl_alloccharobj (hcl_t* hcl, int brand, const hcl_ooch_t* ptr, hcl_oow_t len) { - return alloc_numeric_array (hcl, ptr, len, HCL_OBJ_TYPE_CHAR, HCL_SIZEOF(hcl_ooch_t), 1, 0); + return alloc_numeric_array (hcl, brand, ptr, len, HCL_OBJ_TYPE_CHAR, HCL_SIZEOF(hcl_ooch_t), 1, 0); } -hcl_oop_t hcl_allocbyteobj (hcl_t* hcl, const hcl_oob_t* ptr, hcl_oow_t len) +hcl_oop_t hcl_allocbyteobj (hcl_t* hcl, int brand, const hcl_oob_t* ptr, hcl_oow_t len) { - return alloc_numeric_array (hcl, ptr, len, HCL_OBJ_TYPE_BYTE, HCL_SIZEOF(hcl_oob_t), 0, 0); + return alloc_numeric_array (hcl, brand, ptr, len, HCL_OBJ_TYPE_BYTE, HCL_SIZEOF(hcl_oob_t), 0, 0); } -hcl_oop_t hcl_allochalfwordobj (hcl_t* hcl, const hcl_oohw_t* ptr, hcl_oow_t len) +hcl_oop_t hcl_allochalfwordobj (hcl_t* hcl, int brand, const hcl_oohw_t* ptr, hcl_oow_t len) { - return alloc_numeric_array (hcl, ptr, len, HCL_OBJ_TYPE_HALFWORD, HCL_SIZEOF(hcl_oohw_t), 0, 0); + return alloc_numeric_array (hcl, brand, ptr, len, HCL_OBJ_TYPE_HALFWORD, HCL_SIZEOF(hcl_oohw_t), 0, 0); } -hcl_oop_t hcl_allocwordobj (hcl_t* hcl, const hcl_oow_t* ptr, hcl_oow_t len) +hcl_oop_t hcl_allocwordobj (hcl_t* hcl, int brand, const hcl_oow_t* ptr, hcl_oow_t len) { - return alloc_numeric_array (hcl, ptr, len, HCL_OBJ_TYPE_WORD, HCL_SIZEOF(hcl_oow_t), 0, 0); + return alloc_numeric_array (hcl, brand, ptr, len, HCL_OBJ_TYPE_WORD, HCL_SIZEOF(hcl_oow_t), 0, 0); } @@ -227,6 +229,7 @@ static HCL_INLINE int decode_spec (hcl_t* hcl, hcl_oop_t _class, hcl_oow_t vlen, hcl_oop_t hcl_instantiate (hcl_t* hcl, hcl_oop_t _class, const void* vptr, hcl_oow_t vlen) { +#if 0 hcl_oop_t oop; hcl_obj_type_t type; hcl_oow_t alloclen; @@ -292,12 +295,17 @@ hcl_oop_t hcl_instantiate (hcl_t* hcl, hcl_oop_t _class, const void* vptr, hcl_o if (oop) HCL_OBJ_SET_CLASS (oop, _class); hcl_poptmps (hcl, tmp_count); return oop; +#endif + + hcl->errnum = HCL_ENOIMPL; + return HCL_NULL; } #if defined(HCL_USE_OBJECT_TRAILER) hcl_oop_t hcl_instantiatewithtrailer (hcl_t* hcl, hcl_oop_t _class, hcl_oow_t vlen, const hcl_oob_t* tptr, hcl_oow_t tlen) { +#if 0 hcl_oop_t oop; hcl_obj_type_t type; hcl_oow_t alloclen; @@ -329,6 +337,10 @@ hcl_oop_t hcl_instantiatewithtrailer (hcl_t* hcl, hcl_oop_t _class, hcl_oow_t vl if (oop) HCL_OBJ_SET_CLASS (oop, _class); hcl_poptmps (hcl, tmp_count); return oop; +#endif + + hcl->errnum = HCL_ENOIMPL; + return HCL_NULL; } #endif @@ -340,56 +352,23 @@ hcl_oop_t hcl_instantiatewithtrailer (hcl_t* hcl, hcl_oop_t _class, hcl_oow_t vl hcl_oop_t hcl_makenil (hcl_t* hcl) { - hcl_oop_t obj; - - obj = hcl_allocoopobj (hcl, 0); - if (obj) - { - HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_NIL); - } - - return obj; + return hcl_allocoopobj (hcl, HCL_BRAND_NIL, 0); } hcl_oop_t hcl_maketrue (hcl_t* hcl) { - hcl_oop_t obj; - - obj = hcl_allocoopobj (hcl, 0); - if (obj) - { - HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_TRUE); - } - - return obj; + return hcl_allocoopobj (hcl, HCL_BRAND_TRUE, 0); } hcl_oop_t hcl_makefalse (hcl_t* hcl) { - hcl_oop_t obj; - - obj = hcl_allocoopobj (hcl, 0); - if (obj) - { - HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_FALSE); - } - - return obj; + return hcl_allocoopobj (hcl, HCL_BRAND_FALSE, 0); } hcl_oop_t hcl_makeinteger (hcl_t* hcl, hcl_ooi_t v) { - hcl_oop_t obj; - if (HCL_IN_SMOOI_RANGE(v)) return HCL_SMOOI_TO_OOP(v); - - obj = hcl_allocwordobj (hcl, (hcl_oow_t*)&v, 1); - if (obj) - { - HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_INTEGER); - } - - return obj; + return hcl_allocwordobj (hcl, HCL_BRAND_INTEGER, (hcl_oow_t*)&v, 1); } hcl_oop_t hcl_makecons (hcl_t* hcl, hcl_oop_t car, hcl_oop_t cdr) @@ -399,12 +378,11 @@ hcl_oop_t hcl_makecons (hcl_t* hcl, hcl_oop_t car, hcl_oop_t cdr) hcl_pushtmp (hcl, &car); hcl_pushtmp (hcl, &cdr); - cons = (hcl_oop_cons_t)hcl_allocoopobj (hcl, 2); + cons = (hcl_oop_cons_t)hcl_allocoopobj (hcl, HCL_BRAND_CONS, 2); if (cons) { cons->car = car; cons->cdr = cdr; - HCL_OBJ_SET_FLAGS_BRAND (cons, HCL_BRAND_CONS); } hcl_poptmps (hcl, 2); @@ -414,55 +392,30 @@ hcl_oop_t hcl_makecons (hcl_t* hcl, hcl_oop_t car, hcl_oop_t cdr) hcl_oop_t hcl_makearray (hcl_t* hcl, hcl_oow_t size) { - hcl_oop_t obj; - - obj = hcl_allocoopobj (hcl, size); - if (obj) - { - HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_ARRAY); - } - - return obj; + return hcl_allocoopobj (hcl, HCL_BRAND_ARRAY, size); } hcl_oop_t hcl_makebytearray (hcl_t* hcl, const hcl_oob_t* ptr, hcl_oow_t size) { - hcl_oop_t obj; - - obj = hcl_allocbyteobj (hcl, ptr, size); - if (obj) - { - HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_BYTE_ARRAY); - } - - return obj; + return hcl_allocbyteobj (hcl, HCL_BRAND_BYTE_ARRAY, ptr, size); } hcl_oop_t hcl_makestring (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow_t len) { - hcl_oop_t obj; - - obj = hcl_alloccharobj (hcl, ptr, len); - if (obj) - { - HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_STRING); - } - - return obj; + return hcl_alloccharobj (hcl, HCL_BRAND_STRING, ptr, len); } hcl_oop_t hcl_makeset (hcl_t* hcl, hcl_oow_t inisize) { hcl_oop_set_t obj; - obj = (hcl_oop_set_t)hcl_allocoopobj (hcl, 2); + obj = (hcl_oop_set_t)hcl_allocoopobj (hcl, HCL_BRAND_SET, 2); if (obj) { hcl_oop_oop_t bucket; - HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_SET); obj->tally = HCL_SMOOI_TO_OOP(0); - + hcl_pushtmp (hcl, (hcl_oop_t*)&obj); bucket = (hcl_oop_oop_t)hcl_makearray (hcl, inisize); hcl_poptmp (hcl); @@ -475,6 +428,12 @@ hcl_oop_t hcl_makeset (hcl_t* hcl, hcl_oow_t inisize) } + + +/* ------------------------------------------------------------------------ * + * NGC HANDLING + * ------------------------------------------------------------------------ */ + void hcl_freengcobj (hcl_t* hcl, hcl_oop_t obj) { if (HCL_OOP_IS_POINTER(obj) && HCL_OBJ_GET_FLAGS_NGC(obj)) hcl_freemem (hcl, obj); @@ -482,15 +441,7 @@ void hcl_freengcobj (hcl_t* hcl, hcl_oop_t obj) hcl_oop_t hcl_makengcbytearray (hcl_t* hcl, const hcl_oob_t* ptr, hcl_oow_t len) { - hcl_oop_t obj; - - obj = alloc_numeric_array (hcl, ptr, len, HCL_OBJ_TYPE_BYTE, HCL_SIZEOF(hcl_oob_t), 0, 1); - if (obj) - { - HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_BYTE_ARRAY); - } - - return obj; + return alloc_numeric_array (hcl, HCL_BRAND_BYTE_ARRAY, ptr, len, HCL_OBJ_TYPE_BYTE, HCL_SIZEOF(hcl_oob_t), 0, 1); } hcl_oop_t hcl_remakengcbytearray (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t newsize) @@ -518,15 +469,7 @@ hcl_oop_t hcl_remakengcbytearray (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t newsize) hcl_oop_t hcl_makengcarray (hcl_t* hcl, hcl_oow_t len) { - hcl_oop_t obj; - - obj = alloc_numeric_array (hcl, HCL_NULL, len, HCL_OBJ_TYPE_OOP, HCL_SIZEOF(hcl_oop_t), 0, 1); - if (obj) - { - HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_ARRAY); - } - - return obj; + return alloc_numeric_array (hcl, HCL_BRAND_ARRAY, HCL_NULL, len, HCL_OBJ_TYPE_OOP, HCL_SIZEOF(hcl_oop_t), 0, 1); } hcl_oop_t hcl_remakengcarray (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t newsize) diff --git a/lib/print.c b/lib/print.c index d516f01..5954c14 100644 --- a/lib/print.c +++ b/lib/print.c @@ -188,6 +188,39 @@ static HCL_INLINE int print_char (printer_t* pr, hcl_ooch_t ch) return 0; } +enum +{ + WORD_NIL, + WORD_TRUE, + WORD_FALSE, + + + WORD_SET, + WORD_CFRAME, + WORD_CONTEXT, + WORD_PROCESS, + WORD_PROCESS_SCHEDULER, + WORD_SEMAPHORE +}; + +static struct +{ + hcl_oow_t len; + hcl_ooch_t ptr[20]; +} word[] = +{ + { 4, { '#','n', 'i', 'l' } }, + { 5, { '#','t', 'r', 'u', 'e' } }, + { 6, { '#','f', 'a', 'l', 's', 'e' } }, + + { 6, { '#','<','S','E','T','>' } }, + { 9, { '#','<','C','F','R','A','M','E','>' } }, + { 10, { '#','<','C','O','N','T','E','X','T','>' } }, + { 10, { '#','<','P','R','O','C','E','S','S','>' } }, + { 20, { '#','<','P','R','O','C','E','S','S','-','S','C','H','E','D','U','L','E','R','>' } }, + { 12, { '#','<','S','E','M','A','P','H','O','R','E','>' } } +}; + static int print_object (printer_t* pr, hcl_oop_t obj) { hcl_t* hcl; @@ -195,17 +228,6 @@ static int print_object (printer_t* pr, hcl_oop_t obj) print_stack_t ps; int brand; - static struct - { - hcl_oow_t len; - hcl_ooch_t ptr[10]; - } word[] = - { - { 4, { '#','n', 'i', 'l' } }, - { 5, { '#','t', 'r', 'u', 'e' } }, - { 6, { '#','f', 'a', 'l', 's', 'e' } } - }; - hcl = pr->hcl; next: @@ -223,15 +245,15 @@ next: switch ((brand = HCL_OBJ_GET_FLAGS_BRAND(obj))) { case HCL_BRAND_NIL: - OUTPUT_STRX (pr, word[0].ptr, word[0].len); + OUTPUT_STRX (pr, word[WORD_NIL].ptr, word[WORD_NIL].len); break; case HCL_BRAND_TRUE: - OUTPUT_STRX (pr, word[1].ptr, word[1].len); + OUTPUT_STRX (pr, word[WORD_TRUE].ptr, word[WORD_TRUE].len); break; case HCL_BRAND_FALSE: - OUTPUT_STRX (pr, word[2].ptr, word[2].len); + OUTPUT_STRX (pr, word[WORD_FALSE].ptr, word[WORD_FALSE].len); break; case HCL_BRAND_INTEGER: @@ -428,6 +450,11 @@ next: OUTPUT_CHAR (pr, '|'); break; } + + case HCL_BRAND_SET: + OUTPUT_STRX (pr, word[WORD_SET].ptr, word[WORD_SET].len); + break; + #if 0 case HCL_BRAND_PROCEDURE: OUTPUT_STR (pr, "#"); @@ -438,9 +465,30 @@ next: break; #endif + + case HCL_BRAND_CFRAME: + OUTPUT_STRX (pr, word[WORD_CFRAME].ptr, word[WORD_CFRAME].len); + break; + + case HCL_BRAND_CONTEXT: + OUTPUT_STRX (pr, word[WORD_CONTEXT].ptr, word[WORD_CONTEXT].len); + break; + + case HCL_BRAND_PROCESS: + OUTPUT_STRX (pr, word[WORD_PROCESS].ptr, word[WORD_PROCESS].len); + break; + + case HCL_BRAND_PROCESS_SCHEDULER: + OUTPUT_STRX (pr, word[WORD_PROCESS_SCHEDULER].ptr, word[WORD_PROCESS_SCHEDULER].len); + break; + + case HCL_BRAND_SEMAPHORE: + OUTPUT_STRX (pr, word[WORD_SEMAPHORE].ptr, word[WORD_SEMAPHORE].len); + break; + default: - HCL_ASSERT ("Unknown object type" == HCL_NULL); HCL_DEBUG3 (hcl, "Internal error - unknown object type %d at %s:%d\n", (int)brand, __FILE__, __LINE__); + HCL_ASSERT ("Unknown object type" == HCL_NULL); hcl->errnum = HCL_EINTERN; return -1; } diff --git a/lib/sym.c b/lib/sym.c index be66e3b..b033c6a 100644 --- a/lib/sym.c +++ b/lib/sym.c @@ -160,11 +160,9 @@ static hcl_oop_t find_or_make_symbol (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow } /* create a new symbol since it isn't found in the symbol table */ - symbol = (hcl_oop_char_t)hcl_alloccharobj (hcl, ptr, len); + symbol = (hcl_oop_char_t)hcl_alloccharobj (hcl, HCL_BRAND_SYMBOL, ptr, len); if (symbol) { - HCL_OBJ_SET_FLAGS_BRAND (symbol, HCL_BRAND_SYMBOL); - HCL_ASSERT (tally < HCL_SMOOI_MAX); hcl->symtab->tally = HCL_SMOOI_TO_OOP(tally + 1); hcl->symtab->bucket->slot[index] = (hcl_oop_t)symbol;