hyung-hwan/hcl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

added a test on process handling.
Some checks failed
continuous-integration/drone/push Build is failing
Details

Browse Source 
used hcl_instantiate() in making process-related objects
This commit is contained in:
hyung-hwan 2024-09-12 16:08:16 +09:00
parent 8604c6ddf1
commit 6e9e1d35f4
10 changed files with 113 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
lib/dic.c
View File

@ -147,7 +147,7 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t k
hcl_oop_cons_t pair;
pair = (hcl_oop_cons_t)ass->cdr; /* once found, this must be a pair of method pointers */
HCL_ASSERT (hcl, HCL_IS_CONS(hcl, pair));
HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, value));
HCL_ASSERT (hcl, HCL_IS_COMPILED_BLOCK(hcl, value));
if (is_method & 1) pair->car = value; /* class method */
if (is_method & 2) pair->cdr = value; /* instance method */
/* the class instantiation method goes to both cells.
@ -221,7 +221,7 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t k
{
/* create a new pair that holds a class method at the first cell and an instance method at the second cell */
hcl_oop_t pair;
HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, value));
HCL_ASSERT (hcl, HCL_IS_COMPILED_BLOCK(hcl, value));
hcl_pushvolat (hcl, &key);
pair = hcl_makecons(hcl, (is_method & 1? value: hcl->_nil), (is_method & 2? value: hcl->_nil));
hcl_popvolat (hcl);

56
lib/exec.c
View File

@ -345,7 +345,6 @@ static HCL_INLINE void vm_gettime (hcl_t* hcl, hcl_ntime_t* now)
HCL_SUB_NTIME (now, now, &hcl->exec_start_time); /* now = now - exec_start_time */
}
static HCL_INLINE int vm_sleep (hcl_t* hcl, const hcl_ntime_t* dur)
{
/* TODO: return 1 if it gets into the halting state */
@ -374,7 +373,7 @@ static HCL_INLINE hcl_oop_context_t make_context (hcl_t* hcl, hcl_ooi_t ntmprs)
hcl_oop_context_t ctx;
HCL_ASSERT (hcl, ntmprs >= 0);
/*return (hcl_oop_context_t)hcl_allocoopobj(hcl, HCL_BRAND_CONTEXT, HCL_CONTEXT_NAMED_INSTVARS + (hcl_oow_t)ntmprs);*/
ctx =(hcl_oop_context_t)hcl_instantiatewithtrailer(hcl, hcl->c_block_context, ntmprs, HCL_NULL, 0);
ctx = (hcl_oop_context_t)hcl_instantiate(hcl, hcl->c_block_context, HCL_NULL, ntmprs);
/* TODO: a good way to initialize smooi field to 0 in hcl_insstantiate()?
* for this, there must be a way to specify the type of the member variables...
@ -389,7 +388,7 @@ static HCL_INLINE hcl_oop_function_t make_function (hcl_t* hcl, hcl_oow_t lfsize
hcl_oop_function_t func;
/* the literal frame is placed in the variable part.
* the byte code is placed in the trailer space */
* the byte code is placed in the trailer space. */
/*func = (hcl_oop_function_t)hcl_allocoopobjwithtrailer(hcl, HCL_BRAND_FUNCTION, HCL_FUNCTION_NAMED_INSTVARS + lfsize, bptr, blen);*/
func = (hcl_oop_function_t)hcl_instantiatewithtrailer(hcl, hcl->c_function, lfsize, bptr, blen);
if (HCL_UNLIKELY(!func)) return HCL_NULL;
@ -430,11 +429,11 @@ static HCL_INLINE void fill_function_data (hcl_t* hcl, hcl_oop_function_t func,
func->attr_mask = HCL_SMOOI_TO_OOP(attr_mask);
}
static HCL_INLINE hcl_oop_block_t make_block (hcl_t* hcl)
static HCL_INLINE hcl_oop_block_t make_compiled_block (hcl_t* hcl)
{
/* create a base block used for creation of a block context */
/*return (hcl_oop_block_t)hcl_allocoopobj(hcl, HCL_BRAND_BLOCK, HCL_BLOCK_NAMED_INSTVARS);*/
return (hcl_oop_block_t)hcl_instantiate(hcl, hcl->c_block, HCL_NULL, 0);
return (hcl_oop_block_t)hcl_instantiate(hcl, hcl->c_compiled_block, HCL_NULL, 0);
}
static HCL_INLINE void fill_block_data (hcl_t* hcl, hcl_oop_block_t blk, hcl_ooi_t attr_mask, hcl_ooi_t ip, hcl_oop_context_t homectx)
@ -559,9 +558,15 @@ static hcl_oop_process_t make_process (hcl_t* hcl, hcl_oop_context_t c)
else if (clstksize < 32) clstksize = 32;
hcl_pushvolat (hcl, (hcl_oop_t*)&c);
proc = (hcl_oop_process_t)hcl_allocoopobj(hcl, HCL_BRAND_PROCESS, HCL_PROCESS_NAMED_INSTVARS + stksize + exstksize + clstksize);
/*proc = (hcl_oop_process_t)hcl_allocoopobj(hcl, HCL_BRAND_PROCESS, HCL_PROCESS_NAMED_INSTVARS + stksize + exstksize + clstksize);*/
proc = (hcl_oop_process_t)hcl_instantiate(hcl, hcl->c_process, HCL_NULL, stksize + exstksize + clstksize);
hcl_popvolat (hcl);
if (HCL_UNLIKELY(!proc)) return HCL_NULL;
if (HCL_UNLIKELY(!proc))
{
const hcl_ooch_t* oldmsg = hcl_backuperrmsg(hcl);
hcl_seterrbfmt (hcl, hcl->errnum, "unable to make process - %js", oldmsg);
return HCL_NULL;
}
#if 0
////////////////////
@ -1101,7 +1106,6 @@ static void suspend_process (hcl_t* hcl, hcl_oop_process_t proc)
hcl_oop_process_t nrp;
nrp = find_next_runnable_process(hcl);
if (nrp == proc)
{
/* no runnable process after suspension */
@ -1140,10 +1144,10 @@ static void yield_process (hcl_t* hcl, hcl_oop_process_t proc)
if (proc->state == HCL_SMOOI_TO_OOP(HCL_PROCESS_STATE_RUNNING))
{
/* RUNNING --> RUNNABLE */
hcl_oop_process_t nrp;
HCL_ASSERT (hcl, proc == hcl->processor->active);
HCL_ASSERT (hcl, HCL_IS_PROCESS(hcl, proc));
nrp = find_next_runnable_process(hcl);
/* if there are more than 1 runnable processes, the next
@ -1912,7 +1916,7 @@ static int prepare_new_context (hcl_t* hcl, hcl_oop_block_t op_blk, hcl_ooi_t na
hcl_ooi_t fixed_nargs, actual_nargs, excess_nargs;
/* the receiver must be a block context */
HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, op_blk));
HCL_ASSERT (hcl, HCL_IS_COMPILED_BLOCK(hcl, op_blk));
attr_mask = HCL_OOP_TO_SMOOI(op_blk->attr_mask);
@ -2005,7 +2009,7 @@ static HCL_INLINE int __activate_block (hcl_t* hcl, hcl_oop_block_t op_blk, hcl_
{
int x;
HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, op_blk));
HCL_ASSERT (hcl, HCL_IS_COMPILED_BLOCK(hcl, op_blk));
x = prepare_new_context(
hcl,
@ -2032,7 +2036,7 @@ static HCL_INLINE int activate_block (hcl_t* hcl, hcl_ooi_t nargs, hcl_ooi_t nrv
int x;
op_blk = (hcl_oop_block_t)HCL_STACK_GETOP(hcl, nargs);
HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, op_blk));
HCL_ASSERT (hcl, HCL_IS_COMPILED_BLOCK(hcl, op_blk));
x = __activate_block(hcl, op_blk, nargs, nrvars, 0, 0, &newctx);
if (HCL_UNLIKELY(x <= -1)) return -1;
@ -3775,7 +3779,7 @@ static int execute (hcl_t* hcl)
LOG_INST_2 (hcl, "call %zu %zu", b1, b2);
rcv = HCL_STACK_GETOP(hcl, b1);
if (HCL_IS_BLOCK(hcl, rcv))
if (HCL_IS_COMPILED_BLOCK(hcl, rcv))
{
if (activate_block(hcl, b1, b2) <= -1) goto call2_failed;
break;
@ -4787,7 +4791,7 @@ hcl_logbfmt (hcl, HCL_LOG_STDERR, ">>>%O c->sc=%O sc=%O b2=%d b3=%d nivars=%d nc
HCL_ASSERT (hcl, b1 >= 0);
blkobj = make_block(hcl);
blkobj = make_compiled_block(hcl);
if (HCL_UNLIKELY(!blkobj)) goto oops;
/* the long forward jump instruction has the format of
@ -4954,9 +4958,9 @@ hcl_pfrc_t hcl_pf_process_fork (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
int x;
blk = (hcl_oop_block_t)HCL_STACK_GETARG(hcl, nargs, 0);
if (!HCL_IS_BLOCK(hcl, blk))
if (!HCL_IS_COMPILED_BLOCK(hcl, blk))
{
hcl_seterrbfmt (hcl, HCL_EINVAL, "parameter not block - %O", blk);
hcl_seterrbfmt (hcl, HCL_EINVAL, "parameter not compiled block - %O", blk);
return HCL_PF_FAILURE;
}
@ -5068,8 +5072,14 @@ hcl_pfrc_t hcl_pf_semaphore_new (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
{
hcl_oop_semaphore_t sem;
sem = (hcl_oop_semaphore_t)hcl_allocoopobj(hcl, HCL_BRAND_SEMAPHORE, HCL_SEMAPHORE_NAMED_INSTVARS);
if (HCL_UNLIKELY(!sem)) return HCL_PF_FAILURE;
/*sem = (hcl_oop_semaphore_t)hcl_allocoopobj(hcl, HCL_BRAND_SEMAPHORE, HCL_SEMAPHORE_NAMED_INSTVARS);*/
sem = (hcl_oop_semaphore_t)hcl_instantiate(hcl, hcl->c_semaphore, HCL_NULL, 0);
if (HCL_UNLIKELY(!sem))
{
const hcl_ooch_t* oldmsg = hcl_backuperrmsg(hcl);
hcl_seterrbfmt (hcl, hcl->errnum, "unable to make semaphore - %js", oldmsg);
return HCL_PF_FAILURE;
}
sem->count = HCL_SMOOI_TO_OOP(0);
/* TODO: sem->signal_action? */
@ -5355,8 +5365,14 @@ hcl_pfrc_t hcl_pf_semaphore_group_new (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nar
{
hcl_oop_semaphore_group_t sg;
sg = (hcl_oop_semaphore_group_t)hcl_allocoopobj(hcl, HCL_BRAND_SEMAPHORE_GROUP, HCL_SEMAPHORE_GROUP_NAMED_INSTVARS);
if (HCL_UNLIKELY(!sg)) return HCL_PF_FAILURE;
/*sg = (hcl_oop_semaphore_group_t)hcl_allocoopobj(hcl, HCL_BRAND_SEMAPHORE_GROUP, HCL_SEMAPHORE_GROUP_NAMED_INSTVARS);*/
sg = (hcl_oop_semaphore_group_t)hcl_instantiate(hcl, hcl->c_semaphore_group, HCL_NULL, 0);
if (HCL_UNLIKELY(!sg))
{
const hcl_ooch_t* oldmsg = hcl_backuperrmsg(hcl);
hcl_seterrbfmt (hcl, hcl->errnum, "unable to make semaphore group - %js", oldmsg);
return HCL_PF_FAILURE;
}
sg->sem_io_count = HCL_SMOOI_TO_OOP(0);
sg->sem_count = HCL_SMOOI_TO_OOP(0);

2
lib/gc.c
View File

@ -469,7 +469,7 @@ static kernel_class_info_t kernel_classes[__KCI_MAX__] =
HCL_BLOCK_NAMED_INSTVARS,
0,
HCL_OBJ_TYPE_OOP,
HCL_OFFSETOF(hcl_t, c_block)
HCL_OFFSETOF(hcl_t, c_compiled_block)
},
KCI(KCI_BLOCK_CONTEXT) {

10
lib/hcl-prv.h
View File

@ -997,7 +997,7 @@ struct hcl_compiler_t
hcl_ooi_t depth; /* signed because it starts with -1 */
hcl_fnblk_info_t* info;
hcl_oow_t info_capa;
} fnblk; /* lambda/function block */
} fnblk; /* function block */
struct
{
@ -1594,14 +1594,6 @@ hcl_oop_cons_t hcl_putatdic_method (
int mtype /* 1 for class method, 2 for instance method */
);
/* ========================================================================= */
/* proc.c */
/* ========================================================================= */
hcl_oop_process_t hcl_makeproc (
hcl_t* hcl
);
/* ========================================================================= */
/* gc.c */
/* ========================================================================= */

18
lib/hcl.h
View File

@ -1735,7 +1735,7 @@ struct hcl_t
#endif
hcl_oop_class_t c_function; /* Function */
hcl_oop_class_t c_primitive; /* Primitive */
hcl_oop_class_t c_block; /* CompiledBlock */
hcl_oop_class_t c_compiled_block; /* CompiledBlock */
hcl_oop_class_t c_block_context; /* BlockContext */
hcl_oop_class_t c_process; /* Process */
@ -2098,8 +2098,8 @@ typedef enum hcl_concode_t hcl_concode_t;
/*#define HCL_IS_FUNCTION(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_FUNCTION)*/
#define HCL_IS_FUNCTION(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_function)
/*#define HCL_IS_BLOCK(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_BLOCK)*/
#define HCL_IS_BLOCK(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_block)
/*#define HCL_IS_COMPILED_BLOCK(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_BLOCK)*/
#define HCL_IS_COMPILED_BLOCK(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_compiled_block)
/*#define HCL_IS_CLASS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CLASS)*/
#define HCL_IS_CLASS(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_class)
@ -2127,9 +2127,15 @@ typedef enum hcl_concode_t hcl_concode_t;
#define HCL_IS_BIGINT(hcl,v) (HCL_OOP_IS_POINTER(v) && (HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PBIGINT || HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_NBIGINT))
#define HCL_IS_FPDEC(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_FPDEC)
#define HCL_IS_PROCESS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PROCESS)
#define HCL_IS_SEMAPHORE(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SEMAPHORE)
#define HCL_IS_SEMAPHORE_GROUP(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SEMAPHORE_GROUP)
/*#define HCL_IS_PROCESS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PROCESS)*/
#define HCL_IS_PROCESS(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_process)
/*#define HCL_IS_SEMAPHORE(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SEMAPHORE)*/
#define HCL_IS_SEMAPHORE(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_semaphore)
/*#define HCL_IS_SEMAPHORE_GROUP(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SEMAPHORE_GROUP)*/
#define HCL_IS_SEMAPHORE_GROUP(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_semaphore_group)
#define HCL_CONS_CAR(v) (((hcl_cons_t*)(v))->car)
#define HCL_CONS_CDR(v) (((hcl_cons_t*)(v))->cdr)

12
lib/obj.c
View File

@ -173,14 +173,8 @@ hcl_oop_t hcl_allocoopobjwithtrailer (hcl_t* hcl, int brand, hcl_oow_t size, con
/* [NOTE] this is not converted to a SMOOI object */
hdr->slot[size] = (hcl_oop_t)blen;
if (bptr)
{
HCL_MEMCPY (&hdr->slot[size + 1], bptr, blen);
}
else
{
HCL_MEMSET (&hdr->slot[size + 1], 0, blen);
}
if (bptr) HCL_MEMCPY (&hdr->slot[size + 1], bptr, blen);
else HCL_MEMSET (&hdr->slot[size + 1], 0, blen);
return (hcl_oop_t)hdr;
}
@ -224,7 +218,7 @@ static HCL_INLINE hcl_oop_t alloc_numeric_array (hcl_t* hcl, int brand, const vo
else
{
/* initialize with zeros when the string pointer is not given */
HCL_MEMSET ((hdr + 1), 0, nbytes_aligned);
HCL_MEMSET (hdr + 1, 0, nbytes_aligned);
}
return hdr;

7
lib/prim.c
View File

@ -719,11 +719,11 @@ static hcl_pfrc_t pf_is_dictionary (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
return HCL_PF_SUCCESS;
}
static hcl_pfrc_t pf_is_block (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
static hcl_pfrc_t pf_is_compiled_block (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
{
hcl_oop_t rv, x;
x = HCL_STACK_GETARG(hcl, nargs, 0);
rv = (HCL_IS_BLOCK(hcl, x))? hcl->_true: hcl->_false;
rv = (HCL_IS_COMPILED_BLOCK(hcl, x))? hcl->_true: hcl->_false;
HCL_STACK_SETRET (hcl, nargs, rv);
return HCL_PF_SUCCESS;
}
@ -1281,8 +1281,7 @@ static pf_t builtin_prims[] =
{ 1, 1, pf_is_array, 6, { 'a','r','r','a','y','?' } },
{ 1, 1, pf_is_bytearray, 10, { 'b','y','t','e','a','r','r','a','y','?' } },
{ 1, 1, pf_is_dictionary, 11, { 'd','i','c','t','i','o','n','a','r','y','?' } },
{ 1, 1, pf_is_block, 7, { 'l','a','m','b','d','a','?' } },
{ 1, 1, pf_is_block, 4, { 'f','u','n','?' } },
{ 1, 1, pf_is_compiled_block, 4, { 'f','u','n','?' } },
{ 1, 1, pf_is_class, 6, { 'c','l','a','s','s','?' } },
{ 1, 1, pf_is_object, 7, { 'o','b','j','e','c','t','?' } },

1
t/Makefile.am
View File

@ -5,6 +5,7 @@ check_SCRIPTS = \
fun-01.hcl \
insta-01.hcl \
insta-02.hcl \
proc-01.hcl \
ret-01.hcl \
retvar-01.hcl \
va-01.hcl \

1
t/Makefile.in
View File

@ -477,6 +477,7 @@ check_SCRIPTS = \
fun-01.hcl \
insta-01.hcl \
insta-02.hcl \
proc-01.hcl \
ret-01.hcl \
retvar-01.hcl \
va-01.hcl \

50
t/proc-01.hcl Normal file
View File

@ -0,0 +1,50 @@
z1 := 0
z2 := 0
defun loop1() {
| k |
k := 1
while (< k 100) {
printf "loop1 => %d\n" k
k := (+ k 2)
yield
}
z1 := k
sem-signal s1
}
defun loop2() {
| k |
k := 0
while (< k 100) {
printf "loop2 => %d\n" k
k := (+ k 2)
yield
}
z2 := k
sem-signal s2
}
s1 := (sem-new)
s2 := (sem-new)
p1 := (fork loop1)
p2 := (fork loop2)
##suspend p1
##suspend p2
##resume p1
##resume p2
sem-wait s1
sem-wait s2
if (== z1 101) { printf "OK: z1 is %d\n" z1 } \
else { printf "ERROR: z1 is not 101 - %d\n" z1 }
if (== z2 100) { printf "OK: z2 is %d\n" z2 } \
else { printf "ERROR: z1 is not 100 - %d\n" z2 }