Commit 43588838 authored by Bernd Paysan's avatar Bernd Paysan

Make closures work with extraxt:

parent bc203740
Pipeline #662 passed with stage
in 8 minutes and 46 seconds
......@@ -22,15 +22,6 @@
$10 stack: locals-sizes
$10 stack: locals-lists
: doesxt, ( xt -- ) postpone does-xt , ;
Create do-closure \G vtable prototype for closures
dodoes: latestxt !
' doesxt, set-optimizer
' noop set->int \ closures don't have a full header, so the default
' (noname->comp) set->comp \ actions (that check flags) don't work
Defer end-d ( ... xt -- ... )
\ is either EXECUTE (for {: ... :}*) or END-DCLOSURE (for [{: ... :}*).
\ xt is either ' NOOP or [: ]] r> lp! [[ ;], which restores LP.
......@@ -109,25 +100,34 @@ locals-types definitions
forth definitions
: (closure-;]) ( closure-sys lastxt -- )
]
>r r@ dup >namevt @ >vtextra ! vt,
postpone THEN
orig? r> >namevt @ swap ! drop
wrap! pop-locals ;
: closure-:-hook ( sys -- sys addr xt n )
\ addr is the nfa of the defined word, xt its xt
latest latestxt
clear-leave-stack
dead-code off
defstart ;
: closure> ( body -- addr ) \ gforth-experimental closure-end
\G create trampoline head
>l dodoes: >l lp@
[ ' do-closure cell- @ ]L >l
[ cell maxaligned cell <> ] [IF] 0 >l [THEN] ;
doextraxt: >l >l lp@ cell+ ;
: end-dclosure ( unravel-xt -- closure-sys )
>r wrap@
postpone lit >mark
]] closure> [[ r> execute ]] AHEAD BUT THEN [[
]] closure> [[ r> execute ]] AHEAD [[
action-of :-hook >r ['] closure-:-hook is :-hook
:noname
r> is :-hook
case locals-size @ \ special optimizations for few locals
cell of ]] @ >l [[ endof
2 cells of ]] 2@ 2>l [[ endof
]] lp+!# [[ dup negate , ]] laddr# [[ 0 , dup ]] literal move [[
endcase
['] (closure-;]) defstart last @ lastcfa @ defstart ;
['] (closure-;]) colon-sys-xt-offset stick ;
: [{: ( -- vtaddr u latest latestxt wid 0 ) \ gforth-experimental start-closure
\G starts a closure. Closures first declare the locals frame they are
......
......@@ -186,7 +186,7 @@ synonym section-offset section-end
: comp-image ( "image-file1" "image-file2" "new-image" -- )
name slurp-file { file1 fsize1 }
file1 fsize1 s" Gforth5" search 0= abort" not a Gforth image"
file1 fsize1 s" Gforth6" search 0= abort" not a Gforth image"
drop 8 + file1 - { header-offset }
file1 fsize1 header-offset /string to size1 to image1
size1 aligned size1 <> abort" unaligned image size"
......
......@@ -2563,42 +2563,29 @@ Cond: ['] T ' H alit, ;Cond
\ \ threading model 13dec92py
\ modularized 14jun97jaw
T 2 cells H Value xt>body
T 1 cells H Value xt>body
: (>body) ( cfa -- pfa )
xt>body + ; ' (>body) plugin-of t>body
: fillcfa ( usedcells -- )
T cells H xt>body swap -
assert1( dup 0 >= )
0 ?DO 0 X c, tchar +LOOP ;
: (doer,) ( ghost -- )
addr, 1 fillcfa ; ' (doer,) plugin-of doer,
addr, ; ' (doer,) plugin-of doer,
: (docol,) ( -- ) [G'] :docol (doer,) ; ' (docol,) plugin-of docol,
' NOOP plugin-of ca>native
: (doprim,) ( -- )
there xt>body + ca>native T a, H 1 fillcfa ; ' (doprim,) plugin-of doprim,
there xt>body + ca>native T a, H ; ' (doprim,) plugin-of doprim,
: (doeshandler,) ( -- )
T H ; ' (doeshandler,) plugin-of doeshandler,
Defer gset-extra
: (dodoes,) ( does-action-ghost -- )
]comp [G'] :dodoes addr, comp[
dup gset-extra
addr,
2 fillcfa ;
: doextraxt, ( does-action-ghost -- )
]comp [G'] :doextraxt addr, comp[
0 addr,
gset-extra
2 fillcfa ; ' doextraxt, plugin-of dodoes,
gset-extra ; ' doextraxt, plugin-of dodoes,
: (dlit,) ( n -- ) compile lit td, ; ' (dlit,) plugin-of dlit,
......@@ -2932,7 +2919,6 @@ Cond: DOES>
\ compile :dodoes gexecute
\ T here H tcell - reloff
2 refered
0 fillcfa
;
: takeover-x-semantics ( S constructor-ghost new-ghost -- )
......@@ -3891,7 +3877,7 @@ Cond: postpone ( -- ) \ name
hex
>CROSS
Create magic s" Gforth5x" here over allot swap move
Create magic s" Gforth6x" here over allot swap move
bigendian 1+ \ strangely, in magic big=0, little=1
tcell 1 = 0 and or
......
......@@ -303,7 +303,7 @@ typedef union {
typedef Label *Xt;
/* PFA gives the parameter field address corresponding to a cfa */
#define PFA(cfa) (((Cell *)cfa)+2)
#define PFA(cfa) (((Cell *)cfa)+1)
/* PFA1 is a special version for use just after a NEXT1 */
#define PFA1(cfa) PFA(cfa)
/* CODE_ADDRESS is the address of the code jumped to through the code field */
......
......@@ -1994,7 +1994,7 @@ static FILE *checkimage(char *path, int len, char *imagename)
return NULL;
}
preamblesize+=8;
} while(memcmp(magic,"Gforth5",7));
} while(memcmp(magic,"Gforth6",7));
if (debug) {
fprintf(stderr,"Magic found: %*s ", 6, magic);
print_sizes(magic[7]);
......
......@@ -151,7 +151,7 @@ Defer check-shadow ( addr u wid -- )
[ [IFDEF] prelude-mask ] prelude, [ [THEN] ]
dup aligned here + dup maxaligned >align
view,
dup cell+ here + dup maxaligned >align
dup here + dup maxaligned >align
nlstring,
r> 1 or A, 0 A, here last ! \ link field; before revealing, it contains the
\ tagged reveal-into wordlist
......@@ -159,8 +159,7 @@ Defer check-shadow ( addr u wid -- )
[ [IFDEF] prelude-mask ]
next-prelude @ 0<> prelude-mask and lastflags cset
next-prelude off
[ [THEN] ]
cfalign ;
[ [THEN] ] ;
defer record-name ( -- )
' noop is record-name
......@@ -196,7 +195,7 @@ defer header ( -- ) \ gforth
['] nextname-header IS (header) ;
: noname, ( -- )
0 last ! vt, here cell+ dup cfaligned >align 0 ( alias-mask ) , 0 , 0 , ;
0 last ! vt, here dup cfaligned >align 0 ( alias-mask ) , 0 , 0 , ;
: noname-header ( -- )
noname, input-stream ;
......@@ -255,7 +254,7 @@ Defer char@ ( addr u -- char addr' u' )
' noop Alias recurse
\g Alias to the current definition.
unlock tlastcfa @ >body lock AConstant lastcfa
unlock tlastcfa @ lock >body AConstant lastcfa
\ this is the alias pointer in the recurse header, named lastcfa.
\ changing lastcfa now changes where recurse aliases to
\ it's always an alias of the current definition
......@@ -265,7 +264,7 @@ unlock tlastcfa @ >body lock AConstant lastcfa
: cfa, ( code-address -- ) \ gforth cfa-comma
here
dup lastcfa !
0 A, 0 ,
0 A,
code-address! ;
defer basic-block-end ( -- )
......
......@@ -524,12 +524,12 @@ const Create ???
\ also heuristic
dup head? 0= IF drop ['] ??? THEN ;
cell% 2* 0 0 field >body ( xt -- a_addr ) \ core to-body
cell% 0 0 field >body ( xt -- a_addr ) \ core to-body
\G Get the address of the body of the word represented by @i{xt} (the
\G address of the word's data field).
drop drop
cell% -2 * 0 0 field body> ( xt -- a_addr )
cell% -1 * 0 0 field body> ( xt -- a_addr )
drop drop
' @ alias >code-address ( xt -- c_addr ) \ gforth
......@@ -539,15 +539,11 @@ cell% -2 * 0 0 field body> ( xt -- a_addr )
\G If @i{xt} is the execution token of a child of a @code{DOES>} word,
\G @i{a-addr} is the start of the Forth code after the @code{DOES>};
\G Otherwise @i{a-addr} is 0.
dup @ dodoes: = if
cell+ @
dup @ doextraxt: = if
>namevt @ >vtextra @ >body
else
dup @ doextraxt: = if
>namevt @ >vtextra @ >body
else
drop 0
then
endif ;
drop 0
then ;
' ! alias code-address! ( c_addr xt -- ) \ gforth
\G Create a code field with code address @i{c-addr} at @i{xt}.
......
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