--- gforth/prim 2002/09/24 16:50:28 1.99 +++ gforth/prim 2002/12/30 22:41:07 1.111 @@ -105,6 +105,7 @@ \E \E set-current \E store-optimization on +\E ' noop tail-nextp2 ! \ now INST_TAIL just stores, but does not jump \ \ @@ -148,7 +149,9 @@ lit ( #w -- w ) gforth execute ( xt -- ) core ""Perform the semantics represented by the execution token, @i{xt}."" +#ifndef NO_IP ip=IP; +#endif IF_spTOS(spTOS = sp[0]); SUPER_END; EXEC(xt); @@ -156,7 +159,9 @@ EXEC(xt); perform ( a_addr -- ) gforth ""@code{@@ execute}."" /* and pfe */ +#ifndef NO_IP ip=IP; +#endif IF_spTOS(spTOS = sp[0]); SUPER_END; EXEC(*(Xt *)a_addr); @@ -813,6 +818,8 @@ lshift ( u1 n -- u2 ) core l_shift : 0 ?DO 2* LOOP ; +\g compare + \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...) define(comparisons, $1= ( $2 -- f ) $6 $3equals @@ -934,8 +941,6 @@ f = FLAG(u1-u2 < u3-u2); : over - >r - r> u< ; -\g internal - sp@ ( -- a_addr ) gforth sp_fetch a_addr = sp+1; @@ -961,7 +966,12 @@ fp = f_addr; ;s ( R:w -- ) gforth semis ""The primitive compiled by @code{EXIT}."" +#ifdef NO_IP +INST_TAIL; +goto *(void *)w; +#else SET_IP((Xt *)w); +#endif \g stack @@ -1081,6 +1091,8 @@ w = sp[u+1]; \ toggle is high-level: 0.11/0.42% +\g memory + @ ( a_addr -- w ) core fetch ""@i{w} is the cell stored at @i{a_addr}."" w = *a_addr; @@ -1202,6 +1214,8 @@ c_addr2 = c_addr1+1; : dup 1+ swap c@ ; +\g compiler + (f83find) ( c_addr u f83name1 -- f83name2 ) new paren_f83find for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next)) if ((UCell)F83NAME_COUNT(f83name1)==u && @@ -1279,7 +1293,8 @@ while(u1--) ASCII strings (larger if ubits is large), and should share no divisors with ubits. */ -unsigned rot = ((char []){5,0,1,2,3,4,5,5,5,5,3,5,5,5,5,7,5,5,5,5,7,5,5,5,5,6,5,5,5,5,7,5,5})[ubits]; +static char rot_values[] = {5,0,1,2,3,4,5,5,5,5,3,5,5,5,5,7,5,5,5,5,7,5,5,5,5,6,5,5,5,5,7,5,5}; +unsigned rot = rot_values[ubits]; Char *cp = c_addr; for (ukey=0; cp>(ubits-rot))) @@ -1595,19 +1610,19 @@ wior = IOR(rename(tilde_cstr(c_addr1, u1 file-position ( wfileid -- ud wior ) file file_position /* !! use tell and lseek? */ -ud = LONG2UD(ftell((FILE *)wfileid)); -wior = IOR(UD2LONG(ud)==-1); +ud = OFF2UD(ftello((FILE *)wfileid)); +wior = IOR(UD2OFF(ud)==-1); reposition-file ( ud wfileid -- wior ) file reposition_file -wior = IOR(fseek((FILE *)wfileid, UD2LONG(ud), SEEK_SET)==-1); +wior = IOR(fseeko((FILE *)wfileid, UD2OFF(ud), SEEK_SET)==-1); file-size ( wfileid -- ud wior ) file file_size struct stat buf; wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1); -ud = LONG2UD(buf.st_size); +ud = OFF2UD(buf.st_size); resize-file ( ud wfileid -- wior ) file resize_file -wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2LONG(ud))==-1); +wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2OFF(ud))==-1); read-file ( c_addr u1 wfileid -- u2 wior ) file read_file /* !! fread does not guarantee enough */ @@ -1708,12 +1723,8 @@ r = d; #endif f>d ( r -- d ) float f_to_d -#ifdef BUGGY_LONG_LONG -d.hi = ldexp(r,-(int)(CELL_BITS)) - (r<0); -d.lo = r-ldexp((Float)d.hi,CELL_BITS); -#else -d = r; -#endif +extern DCell double2ll(Float r); +d = double2ll(r); f! ( r f_addr -- ) float f_store ""Store @i{r} into the float at address @i{f-addr}."" @@ -1803,15 +1814,9 @@ floor ( r1 -- r2 ) float /* !! unclear wording */ r2 = floor(r1); -fround ( r1 -- r2 ) float f_round +fround ( r1 -- r2 ) gforth f_round ""Round to the nearest integral value."" -/* !! unclear wording */ -#ifdef HAVE_RINT r2 = rint(r1); -#else -r2 = floor(r1+0.5); -/* !! This is not quite true to the rounding rules given in the standard */ -#endif fmax ( r1 r2 -- r3 ) float f_max if (r1 @ >r ; -\ acondbranch(forthname,stackeffect,restline,code,forthcode) +\ acondbranch(forthname,stackeffect,restline,code1,code2,forthcode) \ this is non-syntactical: code must open a brace that is closed by the macro define(acondbranch, $1 ( `#'a_target $2 ) $3 -$4 SET_IP((Xt *)a_target); +$4 #ifdef NO_IP INST_TAIL; +#endif +$5 #ifdef NO_IP +JUMP(a_target); +#else +SET_IP((Xt *)a_target); +INST_TAIL; NEXT_P2; +#endif } SUPER_CONTINUE; -$5 +$6 \+glocals $1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number -$4 lp += nlocals; -SET_IP((Xt *)a_target); +$4 #ifdef NO_IP INST_TAIL; +#endif +$5 lp += nlocals; +#ifdef NO_IP +JUMP(a_target); +#else +SET_IP((Xt *)a_target); +INST_TAIL; NEXT_P2; +#endif } SUPER_CONTINUE; @@ -2490,12 +2535,11 @@ SUPER_CONTINUE; ) acondbranch(a?branch,f --,f83 aquestion_branch, -if (f==0) { +,if (f==0) { ,: - 0= dup \ !f !f \ !! still uses relative addresses - r> dup @ \ !f !f IP branchoffset - rot and + \ !f IP|IP+branchoffset - swap 0= cell and + \ IP'' + 0= dup 0= \ !f f + r> tuck cell+ \ !f branchoffset f IP+ + and -rot @ and or \ f&IP+|!f&branch >r ;) \ we don't need an lp_plus_store version of the ?dup-stuff, because it @@ -2508,8 +2552,13 @@ a?dup-?branch ( #a_target f -- f ) new a if (f==0) { sp++; IF_spTOS(spTOS = sp[0]); - SET_IP((Xt *)a_target); - INST_TAIL; +#ifdef NO_IP +INST_TAIL; +JUMP(a_target); +#else +SET_IP((Xt *)a_target); + INST_TAIL; NEXT_P2; +#endif } SUPER_CONTINUE; @@ -2521,8 +2570,12 @@ few cycles in that case, but is easy to invocation */ if (f!=0) { sp--; +#ifdef NO_IP + JUMP(a_target); +#else SET_IP((Xt *)a_target); NEXT; +#endif } SUPER_CONTINUE; @@ -2532,14 +2585,14 @@ SUPER_CONTINUE; acondbranch(a(next),R:n1 -- R:n2,cmFORTH aparen_next, n2=n1-1; -if (n1) { +,if (n1) { ,: r> r> dup 1- >r IF @ >r ELSE cell+ >r THEN ;) acondbranch(a(loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_loop, n2=n1+1; -if (n2 != nlimit) { +,if (n2 != nlimit) { ,: r> r> 1+ r> 2dup = IF >r 1- >r cell+ >r @@ -2551,7 +2604,7 @@ acondbranch(a(+loop),n R:nlimit R:n1 -- /* dependent upon two's complement arithmetic */ Cell olddiff = n1-nlimit; n2=n1+n; -if ((olddiff^(olddiff+n))>=0 /* the limit is not crossed */ +,if ((olddiff^(olddiff+n))>=0 /* the limit is not crossed */ || (olddiff^n)>=0 /* it is a wrap-around effect */) { ,: r> swap @@ -2566,7 +2619,7 @@ if ((olddiff^(olddiff+n))>=0 /* the li acondbranch(a(-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_minus_loop, UCell olddiff = n1-nlimit; n2=n1-u; -if (olddiff>u) { +,if (olddiff>u) { ,) acondbranch(a(s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_symmetric_plus_loop, @@ -2581,13 +2634,20 @@ if (n<0) { newdiff = -newdiff; } n2=n1+n; -if (diff>=0 || newdiff<0) { +,if (diff>=0 || newdiff<0) { ,) a(?do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth aparen_question_do +#ifdef NO_IP + INST_TAIL; +#endif if (nstart == nlimit) { +#ifdef NO_IP + JUMP(a_target); +#else SET_IP((Xt *)a_target); - INST_TAIL; + INST_TAIL; NEXT_P2; +#endif } SUPER_CONTINUE; : @@ -2601,9 +2661,16 @@ SUPER_CONTINUE; \+xconds a(+do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth aparen_plus_do +#ifdef NO_IP + INST_TAIL; +#endif if (nstart >= nlimit) { +#ifdef NO_IP + JUMP(a_target); +#else SET_IP((Xt *)a_target); - INST_TAIL; + INST_TAIL; NEXT_P2; +#endif } SUPER_CONTINUE; : @@ -2617,9 +2684,16 @@ SUPER_CONTINUE; THEN >r ; a(u+do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth aparen_u_plus_do -if (ustart >= ulimit) { - SET_IP((Xt *)a_target); +#ifdef NO_IP INST_TAIL; +#endif +if (ustart >= ulimit) { +#ifdef NO_IP +JUMP(a_target); +#else +SET_IP((Xt *)a_target); +INST_TAIL; NEXT_P2; +#endif } SUPER_CONTINUE; : @@ -2633,9 +2707,16 @@ SUPER_CONTINUE; THEN >r ; a(-do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth aparen_minus_do -if (nstart <= nlimit) { - SET_IP((Xt *)a_target); +#ifdef NO_IP INST_TAIL; +#endif +if (nstart <= nlimit) { +#ifdef NO_IP +JUMP(a_target); +#else +SET_IP((Xt *)a_target); +INST_TAIL; NEXT_P2; +#endif } SUPER_CONTINUE; : @@ -2649,9 +2730,16 @@ SUPER_CONTINUE; THEN >r ; a(u-do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth aparen_u_minus_do -if (ustart <= ulimit) { - SET_IP((Xt *)a_target); +#ifdef NO_IP INST_TAIL; +#endif +if (ustart <= ulimit) { +#ifdef NO_IP +JUMP(a_target); +#else +SET_IP((Xt *)a_target); +INST_TAIL; NEXT_P2; +#endif } SUPER_CONTINUE; : @@ -2664,8 +2752,44 @@ SUPER_CONTINUE; cell+ THEN >r ; +\ set-next-code and call2 do not appear in images and can be +\ renumbered arbitrarily + +set-next-code ( #w -- ) gforth set_next_code +#ifdef NO_IP +next_code = (Label)w; +#endif + +call2 ( #a_callee #a_ret_addr -- R:a_ret_addr ) gforth +/* call with explicit return address */ +#ifdef NO_IP +INST_TAIL; +JUMP(a_callee); +#else +assert(0); +#endif + +compile-prim1 ( a_prim -- ) gforth compile_prim1 +""compile prim (incl. immargs) at @var{a_prim}"" +compile_prim1(a_prim); + +finish-code ( -- ) gforth finish_code +""Perform delayed steps in code generation (branch resolution, I-cache +flushing)."" +finish_code(); + +forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode +f = forget_dyncode(c_code); + +decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim +""a_prim is the code address of the primitive that has been +compile_prim1ed to a_code"" +a_prim = decompile_code(a_code); + \+ include(peeprules.vmg) +\g end + \+