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

experimented some kind of tail call optimization. but ended up with no good result yet

Browse Source
This commit is contained in:
hyunghwan.chung 2015-06-26 15:49:08 +00:00
parent 0427879198
commit 585f0a6acc
3 changed files with 638 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
stix/lib/debug.c
View File

@ -165,6 +165,7 @@ void print_object (stix_t* stix, stix_oop_t oop)
s.len = STIX_OBJ_GET_SIZE(c->name);
printf ("instance of ");
print_ucs (&s);
printf ("- (%p)", oop);
}
}
}

91
stix/lib/exec.c
View File

@ -26,6 +26,10 @@
#include "stix-prv.h"
/* TODO: context's stack overflow check in various part of this file */
/* TOOD: determine the right stack size */
#define CONTEXT_STACK_SIZE 96
#define LOAD_IP(stix, v_ctx) ((stix)->ip = STIX_OOP_TO_SMINT((v_ctx)->ip))
#define STORE_IP(stix, v_ctx) ((v_ctx)->ip = STIX_OOP_FROM_SMINT((stix)->ip))
@ -71,18 +75,10 @@
static STIX_INLINE int activate_new_method (stix_t* stix, stix_oop_method_t mth, stix_uint16_t next_inst)
{
stix_oow_t stack_size;
stix_oop_context_t ctx;
stix_ooi_t i;
stix_ooi_t ntmprs, nargs;
stack_size = 256; /* TODO: make the stack size configurable or let the compiler choose the right value and store it in the compiled method. if it's stored in the compiled method, the code here can take it*/
stix_pushtmp (stix, (stix_oop_t*)&mth);
ctx = (stix_oop_context_t)stix_instantiate (stix, stix->_method_context, STIX_NULL, stack_size);
stix_poptmp (stix);
if (!ctx) return -1;
/* message sending requires a receiver to be pushed.
* the stack pointer of the sending context cannot be -1.
* if one-argumented message is invoked the stack of the
@ -113,6 +109,26 @@ static STIX_INLINE int activate_new_method (stix_t* stix, stix_oop_method_t mth,
STIX_ASSERT (stix->sp >= 0);
STIX_ASSERT (stix->sp >= nargs);
#if 0
if (!(stix->option.trait & STIX_NOTCO) && next_inst == CODE_RETURN_FROM_BLOCK)
{
/* don't allocate a new method context. reuse the active context.
*
* [NOTE]
* a context stored into a variable by way of 'thisContext' may
* present different contents after this reuse.
*/
STIX_ASSERT (STIX_CLASSOF(stix, stix->active_context) == stix->_block_context);
ctx = stix->active_context;
goto reuse_context;
}
#endif
stix_pushtmp (stix, (stix_oop_t*)&mth);
ctx = (stix_oop_context_t)stix_instantiate (stix, stix->_method_context, STIX_NULL, CONTEXT_STACK_SIZE);
stix_poptmp (stix);
if (!ctx) return -1;
#if 0
if (stix->option.trait & STIX_NOTCO)
{
@ -125,7 +141,7 @@ static STIX_INLINE int activate_new_method (stix_t* stix, stix_oop_method_t mth,
switch (next_inst)
{
case (CODE_POP_STACKTOP << 8) | CODE_RETURN_STACKTOP:
case (CODE_POP_STACKTOP << 8) | CODE_RETURN_RECEIVER:
case (CODE_POP_STACKTOP << 8) | CODE_RETUCEIVER:
case CODE_RETURN_STACKTOP:
case CODE_RETURN_RECEIVER:
/* tail-call optimization */
@ -146,8 +162,7 @@ static STIX_INLINE int activate_new_method (stix_t* stix, stix_oop_method_t mth,
}
#endif
ctx->ip = 0;
ctx->ip = STIX_OOP_FROM_SMINT(0);
/* the stack front has temporary variables including arguments.
*
* New Context
@ -173,7 +188,7 @@ static STIX_INLINE int activate_new_method (stix_t* stix, stix_oop_method_t mth,
ctx->sp = STIX_OOP_FROM_SMINT(ntmprs - 1);
ctx->ntmprs = STIX_OOP_FROM_SMINT(ntmprs);
ctx->method_or_nargs = (stix_oop_t)mth;
/* the 'home' fiedl is stix->_nil for a method context.
/* the 'home' field of a method context is always stix->_nil.
ctx->home = stix->_nil;*/
ctx->origin = ctx; /* point to self */
@ -215,6 +230,42 @@ static STIX_INLINE int activate_new_method (stix_t* stix, stix_oop_method_t mth,
printf ("<<ENTERING>>\n");
return 0;
#if 0
reuse_context:
/* force the class to become a method context */
ctx->_class = stix->_method_context;
ctx->receiver_or_source = ACTIVE_STACK_GET(stix, stix->sp - nargs);
printf ("####### REUSING CONTEXT INSTEAD OF <<ENTERING>> WITH RECEIVER ");
print_object (stix, ctx->receiver_or_source);
printf ("\n");
for (i = 0; i < nargs; i++)
{
ctx->slot[i] = ACTIVE_STACK_GET (stix, stix->sp - nargs + i + 1);
printf ("REUSING ARGUMENT %d - ", (int)i);
print_object (stix, ctx->slot[i]);
printf ("\n");
}
for (; i <= stix->sp; i++) ctx->slot[i] = stix->_nil;
/* keep the sender
ctx->sender =
*/
ctx->ntmprs = STIX_OOP_FROM_SMINT(ntmprs);
ctx->method_or_nargs = (stix_oop_t)mth;
ctx->home = stix->_nil;
ctx->origin = ctx;
/* let SWITCH_ACTIVE_CONTEXT() fill 'ctx->ip' and 'ctx->sp' by putting
* the values to stix->ip and stix->sp */
stix->ip = 0;
stix->sp = ntmprs - 1;
SWITCH_ACTIVE_CONTEXT (stix, ctx);
return 0;
#endif
}
static stix_oop_method_t find_method (stix_t* stix, stix_oop_t receiver, const stix_ucs_t* message, int super)
@ -598,11 +649,16 @@ static int primitive_block_context_value (stix_t* stix, stix_ooi_t nargs)
* while the block context is active
*/
org_blkctx = (stix_oop_context_t)ACTIVE_STACK_GET(stix, stix->sp - nargs);
STIX_ASSERT (STIX_CLASSOF(stix, org_blkctx) == stix->_block_context);
if (STIX_CLASSOF(stix, org_blkctx) != stix->_block_context)
{
printf ("PRIMITVE VALUE RECEIVER IS NOT A BLOCK CONTEXT\n");
return 0;
}
if (org_blkctx->receiver_or_source != stix->_nil)
{
/* this block context has already been activated once.
/* 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.
*/
@ -610,7 +666,6 @@ static int primitive_block_context_value (stix_t* stix, stix_ooi_t nargs)
printf ("PRIM REVALUING AN BLOCKCONTEXT\n");
return 0;
}
STIX_ASSERT (STIX_OBJ_GET_SIZE(org_blkctx) == STIX_CONTEXT_NAMED_INSTVARS);
if (STIX_OOP_TO_SMINT(org_blkctx->method_or_nargs) != nargs)
@ -621,9 +676,8 @@ printf ("PRIM BlockContext value FAIL - NARGS MISMATCH\n");
return 0;
}
/* TODO: what is the right stack size? is 255 too large? any good way to determine it? */
/* create a new block context to clone org_blkctx */
blkctx = (stix_oop_context_t) stix_instantiate (stix, stix->_block_context, STIX_NULL, 255);
blkctx = (stix_oop_context_t) stix_instantiate (stix, stix->_block_context, STIX_NULL, CONTEXT_STACK_SIZE);
if (!blkctx) return -1;
/* getting org_blkctx again to be GC-safe for stix_instantiate() above */
@ -643,6 +697,7 @@ printf ("PRIM BlockContext value FAIL - NARGS MISMATCH\n");
blkctx->receiver_or_source = (stix_oop_t)org_blkctx;
blkctx->home = org_blkctx->home;
blkctx->origin = org_blkctx->origin;
printf ("~~~~~~~~~~ BLOCK VALUING %p TO NEW BLOCK %p\n", org_blkctx, blkctx);
#endif
/* TODO: check the stack size of a block context to see if it's large enough to hold arguments */
@ -667,6 +722,7 @@ printf ("PRIM BlockContext value FAIL - NARGS MISMATCH\n");
blkctx->sp = STIX_OOP_FROM_SMINT(local_ntmprs);
blkctx->sender = (stix_oop_t)stix->active_context;
printf ("<<ENTERING BLOCK>>\n");
SWITCH_ACTIVE_CONTEXT (stix, (stix_oop_context_t)blkctx);
return 1;
}
@ -1227,6 +1283,7 @@ printf ("RETURN_RECEIVER\n");
goto handle_return;
case SUBCMD_RETURN_FROM_BLOCK:
printf ("LEAVING_BLOCK\n");
STIX_ASSERT(STIX_CLASSOF(stix, stix->active_context) == stix->_block_context);
return_value = ACTIVE_STACK_GETTOP(stix);

561
stix/lib/test-005.st Normal file
View File

@ -0,0 +1,561 @@
#class Stix(nil)
{
#dcl(#class) sysdic.
#method(#class) yourself
{
^self.
}
#method yourself
{
^self.
}
#method(#class) dump
{
<primitive: 0>
}
#method dump
{
<primitive: 0>
}
#method(#class) new
{
<primitive: 1>
}
#method(#class) new: anInteger
{
<primitive: 2>
}
#method basicSize
{
<primitive: 3>
^0
}
#method basicAt: anInteger
{
<primitive: 4>
## self error: 'out of range'.
}
#method basicAt: anInteger put: anObject
{
<primitive: 5>
## self error: 'out of range'.
}
#method badReturnError
{
## TODO: implement this
}
#method mustBeBoolean
{
## TODO: implement this
}
#method doesNotUnderstand: aMessageSymbol
{
## TODO: implement this
}
#method error: anErrorString
{
anErrorString dump.
}
}
#class Object(Stix)
{
}
#class NilObject(Stix)
{
}
#class(#pointer) Class(Stix)
{
#dcl spec selfspec superclass subclasses name instvars classvars classinstvars instmthdic classmthdic.
}
#class Magnitude(Object)
{
}
#class Association(Magnitude)
{
#dcl key value.
}
#class Character(Magnitude)
{
}
#class Number(Magnitude)
{
#method add: aNumber
{
<primitive: 7>
}
#method + aNumber
{
<primitive: 7>
}
#method - aNumber
{
<primitive: 8>
}
#method < aNumber
{
<primitive: 9>
}
}
#class SmallInteger(Number)
{
}
#class Boolean(Object)
{
}
#class True(Boolean)
{
#method ifTrue: trueBlock ifFalse: falseBlock
{
^trueBlock value.
}
#method ifTrue: trueBlock
{
^trueBlock value.
}
#method ifFalse: falseBlock
{
^nil.
}
}
#class False(Boolean)
{
#method ifTrue: trueBlock ifFalse: falseBlock
{
^falseBlock value.
}
#method ifTrue: trueBlock
{
^nil.
}
#method ifFalse: falseBlock
{
^falseBlock value.
}
}
#class Collection(Object)
{
}
#class(#byte) ByteArray(Collection)
{
#method at: anInteger
{
^self basicAt: anInteger.
}
#method at: anInteger put: aValue
{
^self basicAt: anInteger put: aValue.
}
}
#class(#pointer) Array(Collection)
{
#method at: anInteger
{
^self basicAt: anInteger.
}
#method at: anInteger put: aValue
{
^self basicAt: anInteger put: aValue.
}
}
#class(#character) String(Array)
{
}
#class(#character) Symbol(Array)
{
}
#class Set(Collection)
{
#dcl tally bucket.
}
#class SymbolSet(Set)
{
}
#class Dictionary(Set)
{
}
#class SystemDictionary(Dictionary)
{
}
#class MethodDictionary(Dictionary)
{
}
#class(#pointer) Context(Stix)
{
}
#class(#pointer) MethodContext(Context)
{
#dcl sender ip sp ntmprs method receiver home origin.
#method pc
{
^ip
}
#method pc: anInteger
{
ip := anInteger.
}
}
#class(#pointer) BlockContext(Context)
{
#dcl caller ip sp ntmprs nargs source home origin.
#method value
{
<primitive: 6>
}
#method value: a
{
<primitive: 6>
}
#method value: a value: b
{
<primitive: 6>
}
#method value: a value: b value: c
{
<primitive: 6>
}
#method whileTrue: aBlock
{
## http://stackoverflow.com/questions/2500483/is-there-a-way-in-a-message-only-language-to-define-a-whiletrue-message-without
## ^(self value) ifTrue: [aBlock value. self whileTrue: aBlock].
| start |
start := thisContext pc.
self value ifFalse: [ ^nil "^self" ].
aBlock value.
thisContext pc: start.
## | start |
## start := thisContext pc.
## ^self value ifTrue: [aBlock value. thisContext pc: start]
## TODO: add restart method.
## self value ifTrue: [ aBlock value. thisContext restart. ].
}
#method pc
{
^ip
}
#method pc: anInteger
{
ip := anInteger.
}
#method sp
{
^sp
}
#method sp: anInteger
{
sp := anInteger.
}
}
#class(#pointer) CompiledMethod(Object)
{
#dcl owner preamble ntmprs nargs code source.
}
#################################################################
## MAIN
#################################################################
## TODO: use #define to define a class or use #class to define a class.
## use #extend to extend a class
## using #class for both feels confusing.
#class Stix
{
}
#class SmallInteger
{
#method getTrue: anInteger
{
^anInteger + 9999.
}
#method inc
{
^self + 1.
}
}
#class TestObject(Object)
{
#dcl(#class) Q R.
#dcl(#classinst) t1 t2.
}
#class MyObject(TestObject)
{
#dcl(#class) C B A.
#method getTrue
{
^true.
}
#method getTrue: anInteger
{
^ anInteger
}
#method getFalse
{
^false
}
#method yyy: aBlock
{
| a |
a := aBlock value.
^a + 99.
}
#method xxx: aBlock
{
| a |
a := self yyy: aBlock.
'KKKKKKKKKKKKKKKKKKKKKKKKKKKKK' dump.
^a.
}
#method(#class) main2
{
| a b c sum |
## ##(10 add: 20) dump.
## (10 + 20) dump.
##
## a := 10 + 20 + 30.
## b := [:x :y | | t z | x := 20. b := 9. x := 10 + 20 ].
##
## (b value: 10 value: 20) dump.
##
## thisContext basicSize dump.
##
## (thisContext basicAt: (8 + 5)) dump.
##
## ^self.
a := self new.
##a yourself.
##b := a getTrue; getFalse.
##b := a getTrue; getFalse; getTrue: 20 + 10.
##b := a getTrue; getFalse; getTrue: 20 + 10; getTrue: 90 + 20.
##b := 3 + 5 getTrue: 20; getTrue: 8 + 1; getTrue: 20; yourself.
b := 3 + 5 inc getTrue: 20 + (30 getTrue: 20; yourself); yourself.
##b := [:q | q ] value: a getTrue.
b dump.
##^self.
## ############################################################
## A := 99.
[:x :y | R := y. ] value: 10 value: 6.
R := R + 1.
R dump.
sum := [ :n | (n < 2) ifTrue: [1] ifFalse: [ n + (sum value: (n - 1))] ].
##sum := [ :n | (n < 2) ifTrue: [1] ifFalse: [ n + (sum value: (n - 1)) + (sum value: (n - 2))] ].
(sum value: R; value: 5) dump.
##sum := [ :n | sum value: 5 ].
##sum value: 5.
#[ 1 2 3] dump.
#[ 4 5 6] dump.
#(abc:def: 2 'string is good' 3 4 (5 6) (7 (8 9)) 10) dump.
#([] #[]) dump.
a := #(abc:def: -2 'string is good' 3 #[2 3 4] 4 (5 6) (7 (8 [4 56] 'hello' 9)) 10 -93952 self true false nil thisContext super).
a at: 3 put: 'hello world'; dump.
a := self new.
(a xxx: [888]) dump.
20 dump.
b := 0.
[ b < 9 ] whileTrue: [ b dump. b := b + 1 ].
S'hello \t\u78966\u8765\u3456\u2723\x20\123world\uD57C\uB85C\uC6B0' dump.
C'\n' dump.
#abc:def: dump.
##a := (11 < 10) ifTrue: [5] ifFalse: [20].
##a dump.
}
#method(#class) main99
{
|a b c|
self main2.
## b := 0.
## [ b < 5 ] whileTrue: [ b dump. b := b + 1 ].
}
#method(#class) getTen
{
^10
}
#method(#class) main
{
|a b sum |
sum := [ :n | (n < 2) ifTrue: [1] ifFalse: [ n + (sum value: (n - 1))] ].
(sum value: 5) dump.
'-------------------------' dump.
b := 0.
[ b < 1000 ] whileTrue: [ b dump. b := b + 1 ].
'-------------------------' dump.
a := #[4 5 6 7] at: 3.
(#[3 2 1] at: 3) dump.
## thisContext value. "the message value must be unresolvable as thisContext is a method context"
## [thisContext value] value.
'-------------------------' dump.
b := 0.
[ b := b + 1. b dump. thisContext value] value.
[self getTen] value dump.
}
}
"
[ a := 20. b := [ a + 20 ]. b value. ] value
^ ^ ^ ^
p1 p3 p4 p2
--------------------------------------------------------------------------------
AC
--------------------------------------------------------------------------------
mc1<active>
mc1->sender := fake_initial_context.
mc1->home := nil.
mc1->origin := mc1.
mc1 p1 -> bc1 is created based on mc1 (mc1 blockCopy:)
bc1->caller := nil
bc1->origin := mc1.
bc1->home := mc1. (the active context is a method context. so just use it as a home).
bc1->source := nil.
mc1 p2 -> bc2 is shallow-copied of bc1. (bc1 value)
bc2->caller := mc1. (mc1 is the active context at p2 time)
bc2->origin := bc1->origin.
bc2->home := bc1->home.
bc2->source := bc1.
bc2 bc3 is created based on bc2. (bc2 blockCopy:)
bc3->caller := nil
bc3->origin := bc2->origin
//bc3->home := bc2.
bc3->home := bc2->source. (the active context is a block context. take from the block context's source */
bc3->source := nil.
bc2 bc4 is shallow-copied of bc3. (bc3 value)
bc4->caller := bc2. (bc2 is the active context at p2 time)
bc4->origin := bc3->origin
bc4->home := bc3->home
bc4->source = bc3.
bc4.
--------------------------------------------------------------------------------
'home' is set when the context is created by blockCopy.
'caller' is set when the context is activated.
all 'origin' fields point to mc1 as a result.
self represents the receiver. that is bc->origin->receiver which is mc1->receiver.
--------------------------------------------------------------------------------
#method ifTrue: trueBlock
{
^trueBlock value.
}
#method whileTrue: aBlock
{
(self value) ifTrue: [aBlock value. self whileTrue: aBlock].
}
[ b < 10 ] whileTrue: [ b dump. b := b + 1 ].
"