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

added hcl_block_t to express a base block. no more reuse of hcl_context_t for the base block

Browse Source
This commit is contained in:
hyung-hwan 2020-10-09 07:14:32 +00:00
parent a69434a96f
commit d127456da8
4 changed files with 126 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
bin/main.c
View File

@ -1160,7 +1160,7 @@ hcl_logufmt (hcl, HCL_LOG_WARN, fmt, ustr, 0x6789);
}
#endif
#if 0
#if 1
// TODO: change the option name
// in the INTERACTIVE mode, the compiler generates MAKE_FUNCTION for lambda functions.
// in the non-INTERACTIVE mode, the compiler generates MAKE_CONTEXT for lambda functions.

123
lib/exec.c
View File

@ -167,7 +167,7 @@ static HCL_INLINE hcl_oop_t make_context (hcl_t* hcl, hcl_ooi_t ntmprs)
return hcl_allocoopobj(hcl, HCL_BRAND_CONTEXT, HCL_CONTEXT_NAMED_INSTVARS + (hcl_oow_t)ntmprs);
}
static HCL_INLINE hcl_oop_t make_function (hcl_t* hcl, hcl_oow_t lfsize, const hcl_oob_t* bptr, hcl_oow_t blen)
static HCL_INLINE hcl_oop_function_t make_function (hcl_t* hcl, hcl_oow_t lfsize, const hcl_oob_t* bptr, hcl_oow_t blen)
{
/* the literal frame is placed in the variable part.
* the byte code is placed in the trailer space */
@ -180,6 +180,10 @@ static HCL_INLINE void fill_function_data (hcl_t* hcl, hcl_oop_function_t func,
* this function has been separated from make_function() to make GC handling simpler */
hcl_oow_t i;
HCL_ASSERT (hcl, nargs >= 0 && nargs <= HCL_SMOOI_MAX);
HCL_ASSERT (hcl, ntmprs >= 0 && ntmprs <= HCL_SMOOI_MAX);
HCL_ASSERT (hcl, nargs <= ntmprs);
/* copy literal frames */
HCL_ASSERT (hcl, lfsize <= HCL_OBJ_GET_SIZE(func) - HCL_FUNCTION_NAMED_INSTVARS);
for (i = 0; i < lfsize; i++)
@ -194,6 +198,25 @@ static HCL_INLINE void fill_function_data (hcl_t* hcl, hcl_oop_function_t func,
func->ntmprs = HCL_SMOOI_TO_OOP(ntmprs);
}
static HCL_INLINE hcl_oop_block_t make_block (hcl_t* hcl)
{
/* create a base block used for creation of a block context */
return hcl_allocoopobj(hcl, HCL_BRAND_BLOCK, HCL_BLOCK_NAMED_INSTVARS);
}
static HCL_INLINE void fill_block_data (hcl_t* hcl, hcl_oop_block_t blk, hcl_ooi_t nargs, hcl_ooi_t ntmprs, hcl_ooi_t ip, hcl_oop_context_t homectx)
{
HCL_ASSERT (hcl, nargs >= 0 && nargs <= HCL_SMOOI_MAX);
HCL_ASSERT (hcl, ntmprs >= 0 && ntmprs <= HCL_SMOOI_MAX);
HCL_ASSERT (hcl, nargs <= ntmprs);
HCL_ASSERT (hcl, ip >= 0 && nargs <= HCL_SMOOI_MAX);
blk->home = homectx;
blk->nargs = HCL_SMOOI_TO_OOP(nargs);
blk->ntmprs = HCL_SMOOI_TO_OOP(ntmprs);
blk->ip = HCL_SMOOI_TO_OOP(ip);
}
static HCL_INLINE int prepare_to_alloc_pid (hcl_t* hcl)
{
hcl_oow_t new_capa;
@ -902,7 +925,7 @@ static void update_sem_heap (hcl_t* hcl, hcl_ooi_t index, hcl_oop_semaphore_t ne
}
/* ------------------------------------------------------------------------- */
static int __activate_context (hcl_t* hcl, hcl_oop_context_t rcv_blkctx, hcl_ooi_t nargs, hcl_oop_context_t* pblkctx)
static int __activate_block (hcl_t* hcl, hcl_oop_block_t rcv_blk, 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
@ -923,35 +946,22 @@ static int __activate_context (hcl_t* hcl, hcl_oop_context_t rcv_blkctx, hcl_ooi
*/
/* the receiver must be a block context */
HCL_ASSERT (hcl, HCL_IS_CONTEXT (hcl, rcv_blkctx));
if (rcv_blkctx->receiver_or_base != 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, HCL_OBJ_GET_SIZE(rcv_blkctx) > HCL_CONTEXT_NAMED_INSTVARS);
HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_ERROR,
"Error - re-valuing of a block context - %O\n", rcv_blkctx);
hcl_seterrbfmt (hcl, HCL_ERECALL, "cannot recall %O", rcv_blkctx);
return -1;
}
HCL_ASSERT (hcl, HCL_OBJ_GET_SIZE(rcv_blkctx) == HCL_CONTEXT_NAMED_INSTVARS);
HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, rcv_blk));
if (HCL_OOP_TO_SMOOI(rcv_blkctx->nargs) != nargs)
if (HCL_OOP_TO_SMOOI(rcv_blk->nargs) != nargs)
{
HCL_LOG3 (hcl, HCL_LOG_IC | 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->nargs), nargs);
"Error - wrong number of arguments to a block %O - expecting %zd, got %zd\n",
rcv_blk, HCL_OOP_TO_SMOOI(rcv_blk->nargs), nargs);
hcl_seterrnum (hcl, HCL_ECALLARG);
return -1;
}
local_ntmprs = HCL_OOP_TO_SMOOI(rcv_blkctx->ntmprs);
local_ntmprs = HCL_OOP_TO_SMOOI(rcv_blk->ntmprs);
HCL_ASSERT (hcl, local_ntmprs >= nargs);
/* create a new block context to clone rcv_blkctx */
hcl_pushtmp (hcl, (hcl_oop_t*)&rcv_blkctx);
/* create a new block context to clone rcv_blk */
hcl_pushtmp (hcl, (hcl_oop_t*)&rcv_blk);
blkctx = (hcl_oop_context_t)make_context(hcl, local_ntmprs);
hcl_poptmp (hcl);
if (!blkctx) return -1;
@ -960,15 +970,16 @@ static int __activate_context (hcl_t* hcl, hcl_oop_context_t rcv_blkctx, hcl_ooi
/* 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];
((hcl_oop_oop_t)blkctx)->slot[i] = ((hcl_oop_oop_t)rcv_blk)->slot[i];
}
#else
blkctx->ip = rcv_blkctx->ip;
blkctx->ntmprs = rcv_blkctx->ntmprs;
blkctx->nargs = rcv_blkctx->nargs;
blkctx->receiver_or_base = (hcl_oop_t)rcv_blkctx;
blkctx->home = rcv_blkctx->home;
blkctx->origin = rcv_blkctx->origin;
blkctx->ip = rcv_blk->ip;
blkctx->ntmprs = rcv_blk->ntmprs;
blkctx->nargs = rcv_blk->nargs;
blkctx->receiver_or_base = (hcl_oop_t)rcv_blk;
blkctx->home = rcv_blk->home;
/* blkctx->origin = rcv_blk->origin; */
blkctx->origin = rcv_blk->home->origin;
#endif
/* TODO: check the stack size of a block context to see if it's large enough to hold arguments */
@ -980,7 +991,7 @@ static int __activate_context (hcl_t* hcl, hcl_oop_context_t rcv_blkctx, hcl_ooi
HCL_STACK_POPS (hcl, nargs + 1); /* pop arguments and receiver */
HCL_ASSERT (hcl, (rcv_blkctx == hcl->initial_context && (hcl_oop_t)blkctx->home == hcl->_nil) || (hcl_oop_t)blkctx->home != hcl->_nil);
HCL_ASSERT (hcl, (rcv_blk == hcl->initial_context && (hcl_oop_t)blkctx->home == hcl->_nil) || (hcl_oop_t)blkctx->home != hcl->_nil);
blkctx->sp = HCL_SMOOI_TO_OOP(-1); /* not important at all */
blkctx->sender = hcl->active_context;
@ -988,15 +999,16 @@ static int __activate_context (hcl_t* hcl, hcl_oop_context_t rcv_blkctx, hcl_ooi
return 0;
}
static HCL_INLINE int activate_context (hcl_t* hcl, hcl_ooi_t nargs)
static HCL_INLINE int activate_block (hcl_t* hcl, hcl_ooi_t nargs)
{
int x;
hcl_oop_context_t rcv, blkctx;
hcl_oop_block_t rcv;
hcl_oop_context_t blkctx;
rcv = (hcl_oop_context_t)HCL_STACK_GETRCV(hcl, nargs);
HCL_ASSERT (hcl, HCL_IS_CONTEXT(hcl, rcv));
rcv = (hcl_oop_block_t)HCL_STACK_GETRCV(hcl, nargs);
HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, rcv));
x = __activate_context(hcl, rcv, nargs, &blkctx);
x = __activate_block(hcl, rcv, nargs, &blkctx);
if (HCL_UNLIKELY(x <= -1)) return -1;
SWITCH_ACTIVE_CONTEXT (hcl, (hcl_oop_context_t)blkctx);
@ -1820,14 +1832,14 @@ static int execute (hcl_t* hcl)
{
switch (HCL_OBJ_GET_FLAGS_BRAND(rcv))
{
case HCL_BRAND_CONTEXT:
if (activate_context(hcl, b1) <= -1) goto oops;
break;
case HCL_BRAND_FUNCTION:
if (activate_function(hcl, b1) <= -1) goto oops;
break;
case HCL_BRAND_BLOCK:
if (activate_block(hcl, b1) <= -1) goto oops;
break;
case HCL_BRAND_PRIM:
if (call_primitive(hcl, b1) <= -1) goto oops;
break;
@ -2346,9 +2358,9 @@ static int execute (hcl_t* hcl)
/* copy the byte codes from the active context to the new context */
#if (HCL_HCL_CODE_LONG_PARAM_SIZE == 2)
func = (hcl_oop_function_t)make_function(hcl, b4, &hcl->active_code[hcl->ip + 3], joff);
func = make_function(hcl, b4, &hcl->active_code[hcl->ip + 3], joff);
#else
func = (hcl_oop_function_t)make_function(hcl, b4, &hcl->active_code[hcl->ip + 2], joff);
func = make_function(hcl, b4, &hcl->active_code[hcl->ip + 2], joff);
#endif
if (HCL_UNLIKELY(!func)) goto oops;
@ -2361,6 +2373,7 @@ static int execute (hcl_t* hcl)
case HCL_CODE_MAKE_BLOCK:
{
#if 0
hcl_oop_context_t blkctx;
/* b1 - number of block arguments
@ -2373,6 +2386,7 @@ static int execute (hcl_t* hcl)
HCL_ASSERT (hcl, b1 >= 0);
HCL_ASSERT (hcl, b2 >= b1);
/* the block context object created here is used as a base
* object for block context activation. activate_context()
* clones a block context and activates the cloned context.
@ -2402,6 +2416,31 @@ static int execute (hcl_t* hcl)
/* push the new block context to the stack of the active context */
HCL_STACK_PUSH (hcl, (hcl_oop_t)blkctx);
#else
hcl_oop_block_t blkobj;
/* 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 (hcl, b1 >= 0);
HCL_ASSERT (hcl, b2 >= b1);
blkobj = make_block(hcl);
if (HCL_UNLIKELY(!blkobj)) goto oops;
/* the long forward jump instruction has the format of
* 11000100 KKKKKKKK or 11000100 KKKKKKKK KKKKKKKK
* depending on HCL_HCL_CODE_LONG_PARAM_SIZE. change 'ip' to point to
* the instruction after the jump. */
fill_block_data (hcl, blkobj, b1, b2, hcl->ip + HCL_HCL_CODE_LONG_PARAM_SIZE + 1, hcl->active_context);
/* push the new block context to the stack of the active context */
HCL_STACK_PUSH (hcl, (hcl_oop_t)blkobj);
#endif
break;
}
@ -2463,7 +2502,7 @@ hcl_oop_t hcl_execute (hcl_t* hcl)
hcl->code.bc.ptr[hcl->code.bc.len - 1] = HCL_CODE_RETURN_STACKTOP;
#endif
func = (hcl_oop_function_t)make_function(hcl, hcl->code.lit.len, hcl->code.bc.ptr, hcl->code.bc.len);
func = make_function(hcl, hcl->code.lit.len, hcl->code.bc.ptr, hcl->code.bc.len);
if (HCL_UNLIKELY(!func)) return HCL_NULL;
/* pass nil for the home context of the initial function */

54
lib/hcl.h
View File

@ -525,6 +525,10 @@ struct hcl_fpdec_t
typedef struct hcl_function_t hcl_function_t;
typedef struct hcl_function_t* hcl_oop_function_t;
#define HCL_BLOCK_NAMED_INSTVARS 4
typedef struct hcl_block_t hcl_block_t;
typedef struct hcl_block_t* hcl_oop_block_t;
#define HCL_CONTEXT_NAMED_INSTVARS 8
typedef struct hcl_context_t hcl_context_t;
typedef struct hcl_context_t* hcl_oop_context_t;
@ -533,8 +537,8 @@ struct hcl_function_t
{
HCL_OBJ_HEADER;
hcl_oop_t ntmprs; /* smooi */
hcl_oop_t nargs; /* smooi */
hcl_oop_t ntmprs; /* smooi. number of temporaries. includes arguments as well */
hcl_oop_t nargs; /* smooi. number of arguments */
hcl_oop_context_t home; /* home context. nil for the initial function */
/* == variable indexed part == */
@ -543,6 +547,19 @@ struct hcl_function_t
/* after the literal frame comes the actual byte code */
};
/* hcl_function_t copies the byte codes and literal frames into itself
* hlc_block_t contains minimal information(ip) for referening byte codes
* and literal frames available in home->origin.
*/
struct hcl_block_t
{
HCL_OBJ_HEADER;
hcl_oop_t ntmprs; /* smooi. number of temporaries. includes arguments as well */
hcl_oop_t nargs; /* smooi. number of arguments */
hcl_oop_t ip; /* smooi. instruction pointer where the byte code begins in home->origin */
hcl_oop_context_t home; /* home context */
};
struct hcl_context_t
{
HCL_OBJ_HEADER;
@ -569,10 +586,9 @@ struct hcl_context_t
hcl_oop_t nargs;
/* it points to the receiver of the message for a method context.
* a base block context(created but not yet activated) has nil in this
* field. if a block context is activated by 'value', it points
* to the block context object used as a base for shallow-copy. */
hcl_oop_t receiver_or_base; /* when used as a base, it's either a context or a function */
* a block context points to a block object and a function context
* points to a function object */
hcl_oop_t receiver_or_base; /* when used as a base, it's either a block or a function */
/* it is set to nil for a method context.
* for a block context, it points to the active context at the
@ -581,19 +597,21 @@ struct hcl_context_t
* an activated block context copies this field from the base block context. */
hcl_oop_context_t home; /* context or nil */
/* it points to the method context created of the method defining the code
* of this context. a method context points to itself. a block context
* points to the method context where it is created. another block context
* created within the block context also points to the same method context.
* ctx->origin: method context
/* a function context is created with itself in this field. The function
* context creation is based on a function object(initial or lambda/defun).
*
* a block context is created over a block object. it stores
* a function context points to itself in this field. a block context
* points to the function context where it is created. another block context
* created within the block context also points to the same function context.
*
* take note of the following points:
* ctx->origin: function context
* ctx->origin->receiver_or_base: actual function containing byte codes pertaining to ctx.
*
* when a method context is created, it is set to itself. no change is
* made when the method context is activated. when a base block context is
* created (when MAKE_BLOCK or BLOCK_COPY is executed), it is set to the
* origin of the active context. when the base block context is shallow-copied
* for activation (when it is sent 'value'), it is set to the origin of
* the base block context. */
* a base of a block context is a block object but ctx->origin is guaranteed to be
* a function context. so its base is also a function object all the time.
*/
hcl_oop_context_t origin;
/* variable indexed part */
@ -1386,6 +1404,7 @@ enum hcl_brand_t
HCL_BRAND_PRIM,
HCL_BRAND_FUNCTION,
HCL_BRAND_BLOCK,
HCL_BRAND_CONTEXT,
HCL_BRAND_PROCESS,
HCL_BRAND_PROCESS_SCHEDULER,
@ -1430,6 +1449,7 @@ typedef enum hcl_concode_t hcl_concode_t;
#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_FUNCTION(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_FUNCTION)
#define HCL_IS_BLOCK(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_BLOCK)
#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_CONS_CONCODED(hcl,v,concode) (HCL_IS_CONS(hcl,v) && HCL_OBJ_GET_FLAGS_SYNCODE(v) == (concode))

6
lib/print.c
View File

@ -88,6 +88,7 @@ enum
WORD_PRIM,
WORD_FUNCTION,
WORD_BLOCK,
WORD_CONTEXT,
WORD_PROCESS,
WORD_PROCESS_SCHEDULER,
@ -109,6 +110,7 @@ static struct
{ 7, { '#','<','P','R','I','M','>' } },
{ 11, { '#','<','F','U','N','C','T','I','O','N','>' } },
{ 11, { '#','<','B','L','O','C','K','>' } },
{ 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','>' } },
@ -663,6 +665,10 @@ next:
word_index = WORD_FUNCTION;
goto print_word;
case HCL_BRAND_BLOCK:
word_index = WORD_BLOCK;
goto print_word;
case HCL_BRAND_CONTEXT:
word_index = WORD_CONTEXT;
goto print_word;