From d127456da82bbdddf349e10b7aaf14d855727ff8 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Fri, 9 Oct 2020 07:14:32 +0000 Subject: [PATCH] added hcl_block_t to express a base block. no more reuse of hcl_context_t for the base block --- bin/main.c | 2 +- lib/exec.c | 123 ++++++++++++++++++++++++++++++++++------------------ lib/hcl.h | 56 ++++++++++++++++-------- lib/print.c | 6 +++ 4 files changed, 126 insertions(+), 61 deletions(-) diff --git a/bin/main.c b/bin/main.c index a898deb..cf6a278 100644 --- a/bin/main.c +++ b/bin/main.c @@ -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. diff --git a/lib/exec.c b/lib/exec.c index a7a9b1e..aa028bc 100644 --- a/lib/exec.c +++ b/lib/exec.c @@ -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 */ diff --git a/lib/hcl.h b/lib/hcl.h index 3451337..3934017 100644 --- a/lib/hcl.h +++ b/lib/hcl.h @@ -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 - * ctx->origin->receiver_or_base: actual function containing byte codes pertaining to ctx. + /* a function context is created with itself in this field. The function + * context creation is based on a function object(initial or lambda/defun). * - * 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 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. + * + * 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)) diff --git a/lib/print.c b/lib/print.c index df455c6..ba51c35 100644 --- a/lib/print.c +++ b/lib/print.c @@ -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;