Commit e857c87e authored by Bernd Paysan's avatar Bernd Paysan

Removed trampoline for locals; causes more problems than it solves

parent 5876204f
......@@ -69,7 +69,7 @@ vocabulary assembler ( -- ) \ tools-ext
defstart init-asm ;
:noname ( colon-sys1 -- colon-sys2 ) \ tools-ext semicolon-code
( create the [;code] part of a low level defining word )
[ifdef] 0-adjust-locals-size 0-adjust-locals-size [then]
[ifdef] unlocal postpone unlocal [then]
;-hook postpone (;code) basic-block-end finish-code ?colon-sys postpone [
defstart init-asm ;
interpret/compile: ;code ( compilation. colon-sys1 -- colon-sys2 ) \ tools-ext semicolon-code
......
......@@ -20,7 +20,7 @@
require sections.fs
s" address-unit-bits" environment? drop constant bits/au
12 constant maxdoer-tag
11 constant maxdoer-tag
0 value image1
0 value size1
......
......@@ -1129,7 +1129,7 @@ Ghost refill drop
Ghost :docol Ghost :doesjump Ghost :dodoes 2drop drop
Ghost :dovar Ghost dovar-vt Ghost dodoes-vt 2drop drop
Ghost :doextra Ghost doextra-vt Ghost extra, 2drop drop
Ghost :docolloc Ghost :dodoesxt 2drop
Ghost :dodoesxt drop
\ \ Parameter for target systems 06oct92py
......@@ -3164,11 +3164,6 @@ Build: ;Build
by: :doextra ;DO
vt: [G'] extra, gset-compiler ;vt
Builder docolloc-dummy
Build: ;Build
by: :docolloc ;DO
vt: [G'] :loc, gset-compiler ;vt
\ Variables and Constants 05dec92py
Builder (Constant)
......
......@@ -291,6 +291,7 @@ Defining Words
* Supplying names:: Passing definition names as strings
* User-defined Defining Words::
* Deferred Words:: Allow forward references
* Forward:: Auto-resolved forward references
* Aliases::
User-defined Defining Words
......@@ -6227,6 +6228,7 @@ Defining words are used to extend Forth by creating new entries in the dictionar
* Supplying names:: Passing definition names as strings
* User-defined Defining Words::
* Deferred Words:: Allow forward references
* Forward:: Auto-resolved forward references
* Aliases::
@end menu
......@@ -7096,7 +7098,7 @@ An ANS Forth implementation of @code{const-does>} is available in
@file{compat/const-does.fs}.
@node Deferred Words, Aliases, User-defined Defining Words, Defining Words
@node Deferred Words, Forward, User-defined Defining Words, Defining Words
@subsection Deferred Words
@cindex deferred words
......@@ -7202,8 +7204,18 @@ doc-defers
Definitions of these words (except @code{defers}) in ANS Forth are
provided in @file{compat/defer.fs}.
@node Forward, Aliases, Deferred Words, Defining Words
@subsection Forward
@node Aliases, , Deferred Words, Defining Words
The defining word @code{Forward} in @code{forward.fs} allows you to
create forward references, which are resolved automatically, and do
not incur additional costs like the indirection of @code{Defer}.
However, these forward definitions only work for colon definitions.
doc-forward
doc-.unresolved
@node Aliases, , Forward, Defining Words
@subsection Aliases
@cindex aliases
......
......@@ -427,18 +427,6 @@ Label *gforth_engine(Xt *ip0 sr_proto)
#endif
#ifdef CPU_DEP2
CPU_DEP2
#endif
#if defined(DIRECT_THREADED)
Cell trampoline = (Cell)&&I_lp_trampoline;
#else
# if defined(DOUBLY_INDIRECT)
const static Cell* trampoline0 = (Cell*)&&I_lp_trampoline;
const static Cell* trampoline1 = (Cell*)&trampoline0;
Cell trampoline = (Cell)&trampoline1;
# else // indirect
const static Cell* trampoline0 = (Cell*)&&I_lp_trampoline;
Cell trampoline = (Cell)&trampoline0;
# endif
#endif
rp = SPs->rpx;
......
......@@ -118,9 +118,8 @@ extern void* (*realloc_l)(void* addr, size_t size);
#define DOABICODE 8
#define DOSEMIABICODE 9
#define DOEXTRA 10
#define DOCOLLOC 11
#define DODOESXT 12
#define DOER_MAX 12
#define DODOESXT 11
#define DOER_MAX 11
#include "machine.h"
......
......@@ -401,7 +401,6 @@ void gforth_relocate(Cell *image, const Char *bitstring,
case CF(DOABICODE) :
case CF(DOSEMIABICODE):
case CF(DOEXTRA):
case CF(DOCOLLOC):
case CF(DODOESXT):
MAKE_CF(image+i,symbols[CF(token)]); break;
#endif /* !defined(DOUBLY_INDIRECT) */
......
......@@ -118,18 +118,20 @@ User locals-size \ this is the current size of the locals stack
\g sets locals-size to n and generates an appropriate lp+!
locals-size @ swap - compile-lp+! ;
: >docolloc ( -- )
\g turn colon definition into lp restoring trampoline
latestxt @ docol: <> ?EXIT \ !! delete this
docolloc: latestxt code-address!
['] :loc, set-compiler
1 unlocal-state cset ;
\ : >docolloc ( -- )
\ \g turn colon definition into lp restoring trampoline
\ latestxt @ docol: <> ?EXIT \ !! delete this
\ docolloc: latestxt code-address!
\ ['] :loc, set-compiler
\ 1 unlocal-state cset ;
\ change EXIT's compilation action
\ beware: because we need EXIT at the end of the definition, it can't
\ be done with opt: ... ;
:noname unlocal-state @ 1 = if
postpone (unlocal) then
:noname \ unlocal-state @ 1 = if
\ postpone (unlocal)
\ then
0 adjust-locals-size
peephole-compile, ;
' exit make-latest set-optimizer
......@@ -475,9 +477,9 @@ new-locals-map mappedwordlist Constant new-locals-wl
\ new-locals-map ' new-locals >body wordlist-map A! \ !! use special access words
\ and now, finally, the user interface words
: { ( -- vtaddr u latestxt wid 0 ) \ gforth open-brace
>docolloc vtsave \ as locals will mess with their own vttemplate
latestxt get-current
: { ( -- vtaddr u latest latestxt wid 0 ) \ gforth open-brace
( >docolloc ) vtsave \ as locals will mess with their own vttemplate
latest latestxt get-current
get-order new-locals-wl swap 1+ set-order
also locals definitions locals-types
val-part off
......@@ -488,7 +490,7 @@ synonym {: {
locals-types definitions
: } ( vtaddr u latestxt wid 0 a-addr1 xt1 ... -- ) \ gforth close-brace
: } ( vtaddr u latest latestxt wid 0 a-addr1 xt1 ... -- ) \ gforth close-brace
\ ends locals definitions
]
begin
......@@ -499,13 +501,13 @@ locals-types definitions
drop vt,
locals-size @ alignlp-f locals-size ! \ the strictest alignment
previous previous
set-current lastcfa !
set-current lastcfa ! last !
vtrestore
locals-list 0 wordlist-id - TO locals-wordlist ;
synonym :} }
: -- ( vtaddr u latestxt wid 0 ... -- ) \ gforth dash-dash
: -- ( vtaddr u latest latestxt wid 0 ... -- ) \ gforth dash-dash
}
BEGIN [char] } parse dup WHILE
+ 1- c@ dup bl = swap ':' = or UNTIL
......@@ -718,8 +720,8 @@ is free-old-local-names
' locals-:-hook IS :-hook
' locals-;-hook IS ;-hook
[ifdef] 0-adjust-locals-size
:noname 0 adjust-locals-size ; is 0-adjust-locals-size
[ifdef] unlocal
:noname 0 adjust-locals-size ; is unlocal
[then]
[ifdef] colon-sys-xt-offset
colon-sys-xt-offset 3 + to colon-sys-xt-offset
......
......@@ -28,8 +28,7 @@
-&10 Doer: :doabicode
-&11 Doer: :do;abicode
-&12 Doer: :doextra
-&13 Doer: :docolloc
-&14 Doer: :dodoesxt
-&13 Doer: :dodoesxt
-&2 first-primitive
\ this does not work for (at least) (DODOES),
\ so the following routines are commented out
......@@ -256,8 +256,9 @@ Defer char@ ( addr u -- char addr' u' )
\ \ threading 17mar93py
' noop Alias recurse compile-only
\g Call the current definition.
' noop Alias recurse
\g Alias to the current definition.
unlock tlastcfa @ lock AConstant lastcfa
\ this is the alias pointer in the recurse header, named lastcfa.
\ changing lastcfa now changes where recurse aliases to
......@@ -512,9 +513,9 @@ extra>-dummy (doextra-dummy)
THEN
latestxt extra-code! ;
\ call with locals
\ call with locals - unused
docolloc-dummy (docolloc-dummy)
\ docolloc-dummy (docolloc-dummy)
\ comp: to define compile, action
......@@ -633,9 +634,13 @@ comp: ( value-xt to-xt -- )
defer :-hook ( sys1 -- sys2 )
defer free-old-local-names ( -- )
defer ;-hook ( sys2 -- sys1 )
defer 0-adjust-locals-size ( -- )
defer unlocal ( l:locals -- ) immediate ' noop is unlocal
\G Remove locals information from locals stack. You need this when
\G you wrie a word that is e.g. exited by ['] EXIT EXECUTE or by RDROP
\G from the called word.
1 value colon-sys-xt-offset
\ you get get the xt in a colon-sys with COLON-SYS-XT-OFFSET PICK
\g you get the xt in a colon-sys with COLON-SYS-XT-OFFSET PICK
0 Constant defstart
: colon-sys ( -- colon-sys )
......@@ -650,7 +655,7 @@ defer 0-adjust-locals-size ( -- )
: (noname->comp) ( nt -- nt xt ) ['] compile, ;
: (:noname) ( -- colon-sys )
\ common factor of : and :noname
docol, colon-sys ] :-hook unlocal-state off ;
docol, colon-sys ] :-hook ( unlocal-state off ) ;
: : ( "name" -- colon-sys ) \ core colon
free-old-local-names
......
......@@ -317,21 +317,6 @@ Avariable leave-sp leave-stack cs-item-size cells + leave-sp !
Defer exit-like ( -- )
' noop IS exit-like
\ exit optimization: when there is locals-stuff on the return stack,
\ (UNLOCAL) ;S is faster than ;S and also correct, but you must not
\ insert (UNLOCAL) before ;S if there is no locals-stuff on the return
\ stack. If there is an UNLOCAL explicitly in the word, we do not
\ insert (UNLOCAL) in front of any further EXITs.
variable unlocal-state \ 0: no locals, 1: locals, but no unlocal, >1: unlocal
: unlocal ( run-time old-lp nest-sys -- ) \ gforth
\G Remove locals information from return and locals stack. You
\G use this for writing a return-address manipulating word; you
\G call this right before removing a nest-sys (return address) of
\G a word that contains locals.
postpone (unlocal) 2 unlocal-state cset ; immediate compile-only
' ;s @ $8000 xor #primitive exit ( compilation -- ; run-time nest-sys -- ) \ core
\G Return to the calling definition; usually used as a way of
\G forcing an early return from a definition. Before
......@@ -360,9 +345,9 @@ defer adjust-locals-list ( wid -- )
\ quotations
: wrap@ ( -- wrap-sys )
vtsave last @ lastcfa @ leave-sp @ locals-wordlist unlocal-state @ ;
vtsave last @ lastcfa @ leave-sp @ locals-wordlist ( unlocal-state @ ) ;
: wrap! ( wrap-sys -- )
unlocal-state ! to locals-wordlist leave-sp ! lastcfa ! last ! vtrestore ;
( unlocal-state ! ) to locals-wordlist leave-sp ! lastcfa ! last ! vtrestore ;
: int-[: ( -- flag colon-sys )
wrap@ false :noname ;
......
......@@ -92,8 +92,3 @@ doer? :doextra [IF]
: doextra: ( -- addr )
['] (doextra-dummy) >code-address ;
[THEN]
doer? :docolloc [IF]
: docolloc: ( -- addr )
['] (docolloc-dummy) >code-address ;
[THEN]
\ No newline at end of file
......@@ -32,7 +32,7 @@
: does, ['] does-exec peephole-compile, , ;
: umethod, >body cell+ 2@ ['] u#exec peephole-compile, , , ;
: uvar, >body cell+ 2@ ['] u#+ peephole-compile, , , ;
: :loc, >body ['] call-loc peephole-compile, , ;
\ : :loc, >body ['] call-loc peephole-compile, , ;
: (uv!) ( xt addr -- ) 2@ next-task + @ cell- @ swap cells + ! ;
: umethod! ( xt xt-method -- )
......
......@@ -27,7 +27,6 @@
super1 = lit +
super2 = lit call
super2a = lit call-loc
super3 = lit @
\ super4 = lit @ call
\ super5 = @ call
......@@ -54,7 +53,6 @@ super27 = dup @
\ super28 = lit execute \ currently not supported
super29 = o#+ @
super30 = o#+ !
super31 = (unlocal) ;s
\ compare-and-branch; comment them out if we take up work on gforth-native again
cb1 = 0< ?branch
......
......@@ -278,26 +278,6 @@ debugp(stderr, "dodoes to %x, push %x\n", a_retaddr, a_body);
SET_IP(EXTRA_CODE(CFA));
#endif /* !defined(NO_IP) */
(docolloc) ( -- R:a_retaddr R:a_lp R:a_trampoline ) gforth-internal paren_docolloc
""Call a word with locals and create a trampoline to restore the LP at EXIT""
a_trampoline = &trampoline;
a_lp = (Cell*)lp;
#ifdef DEBUG
{
CFA_TO_NAME(CFA);
debugp(stderr,"%08lx: call %08lx %.*s\n",(Cell)ip,(Cell)CFA,
len,name);
}
#endif
#ifdef NO_IP
a_retaddr = next_code;
INST_TAIL;
JUMP(PFA(CFA));
#else /* !defined(NO_IP) */
a_retaddr = (Cell *)IP;
SET_IP((Xt *)PFA(CFA));
#endif /* !defined(NO_IP) */
(dodoesxt) ( -- a_body ) gforth-internal paren_dodoesxt
a_body = PFA(CFA);
#ifndef NO_IP
......@@ -2250,21 +2230,20 @@ and return @i{ior}=0, @i{flag}=true and @i{u2} equal to the size of the file nam
If the length of the file name is greater than @i{u1},
store first @i{u1} characters from file name into the buffer and
indicate "name too long" with @i{ior}, @i{flag}=true, and @i{u2}=@i{u1}.""
struct dirent dent;
struct dirent * dresult;
readdir_r((DIR *)wdirid, &dent, &dresult);
dresult=readdir((DIR *)wdirid);
wior = 0;
flag = -1;
if(dresult == NULL) {
u2 = 0;
flag = 0;
} else {
u2 = strlen((char *)dent.d_name);
u2 = strlen((char *)dresult->d_name);
if(u2 > u1) {
u2 = u1;
wior = -512-ENAMETOOLONG;
}
memmove(c_addr, dent.d_name, u2);
memmove(c_addr, dresult->d_name, u2);
}
close-dir ( wdirid -- wior ) gforth close_dir
......@@ -3407,29 +3386,6 @@ goto *(void *)a_retaddr;
SET_IP((Xt *)a_retaddr);
#endif
call-loc ( #a_callee -- R:a_retaddr R:a_lp R:a_trampoline ) new call_loc
""Call a word with locals and create a trampoline to restore the LP at EXIT""
a_trampoline = &trampoline;
a_lp = (Cell*)lp;
#ifdef NO_IP
assert(0);
INST_TAIL;
JUMP(a_callee);
#else
#ifdef DEBUG
{
CFA_TO_NAME((((Cell *)a_callee)-2));
debugp(stderr,"%08lx: call %08lx %.*s\n",(Cell)ip,(Cell)a_callee,
len,name);
}
#endif
a_retaddr = (Cell *)IP;
SET_IP((Xt *)a_callee);
#endif
(unlocal) ( R:a_lp R:w -- ) gforth-internal paren_unlocal
lp = (Address)a_lp;
\+
\g primitive_centric
......
......@@ -887,8 +887,10 @@ set-current
[IFDEF] dovalue:
dovalue: of seevalue endof
[THEN]
docol: of dup umethod? IF seeumethod ELSE seecol THEN endof
docol: of dup umethod? IF seeumethod ELSE seecol THEN endof
[IFDEF] docolloc:
docolloc: of seecol endof
[THEN]
dovar: of seevar endof
[IFDEF] douser:
douser: of seeuser endof
......
......@@ -553,13 +553,11 @@ previous
: n>r ( x1 .. xn n -- r:xn..x1 r:n )
scope r> { n ret }
0 BEGIN dup n < WHILE swap >r 1+ REPEAT >r
ret >r endscope [ unlocal-state off ] ;
' :, set-compiler docol: latestxt code-address!
ret >r endscope ;
: nr> ( r:xn..x1 r:n -- x1 .. xn n )
scope r> r> { ret n }
0 BEGIN dup n < WHILE r> swap 1+ REPEAT
ret >r endscope [ unlocal-state off ] ;
' :, set-compiler docol: latestxt code-address!
ret >r endscope ;
\ x:traverse-wordlist words
......
......@@ -149,6 +149,6 @@ t{ 7 x1 -> 7 22 11 34 17 52 26 13 40 20 10 5 16 8 4 2 1 }t
\ tickable exit
: foo true if 1 {: a :} ['] exit execute then ;
: foo true if 1 {: a :} unlocal ['] exit execute then ;
: bar 2 {: b :} foo b ;
t{ bar -> 2 }
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment