closures.fs 8.09 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
\ A powerful closure implementation

\ Copyright (C) 2018 Free Software Foundation, Inc.

\ This file is part of Gforth.

\ Gforth is free software; you can redistribute it and/or
\ modify it under the terms of the GNU General Public License
\ as published by the Free Software Foundation, either version 3
\ of the License, or (at your option) any later version.

\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\ GNU General Public License for more details.

\ You should have received a copy of the GNU General Public License
\ along with this program. If not, see http://www.gnu.org/licenses/.

\ more information in http://www.complang.tuwien.ac.at/anton/euroforth/ef18/drafts/ertl.pdf

22 23 24
$10 stack: locals-sizes
$10 stack: locals-lists

Anton Ertl's avatar
Anton Ertl committed
25 26 27 28
Defer end-d ( ... xt -- ... )
\ is either EXECUTE (for {: ... :}*) or END-DCLOSURE (for [{: ... :}*).
\ xt is either ' NOOP or [: ]] r> lp! [[ ;], which restores LP.
' execute is end-d
29 30
Defer endref, ( -- )
\ pushes a reference to the location
31
' noop is endref,
32

33 34 35
: >addr ( xt -- addr ) \ gforth-experimental to-addr
    \G convert the xt of a closure on the heap to the @var{addr} with can be
    \G passed to @code{free} to get rid of the closure
36
    [ cell maxaligned ]L - ;
Bernd Paysan's avatar
Bernd Paysan committed
37 38
: alloch ( size -- addr ) \ addr is the end of the allocated region
    dup allocate throw + ;
39
: allocd ( size -- addr ) \ addr is the end of the allocated region
40
    dp +! dp @ ;
41

42
: >lp ( addr -- r:oldlp ) r> lp@ >r >r lp! ;
43
opt: drop ]] laddr# [[ 0 , ]] >r lp! [[ ;
44
: lp> ( r:oldlp -- ) r> r> lp! >r ;
45 46 47 48
opt: drop ]] r> lp! [[ ;

Variable extra-locals ( additional hidden locals size )

49 50
locals-types definitions

51
: :}* ( vtaddr u latest latestxt wid 0 a-addr1 u1 ... xt -- ) \ gforth close-brace-dictionary
52
    0 lit, lits, here cell- >r
53
    compile, ]] >lp [[
Bernd Paysan's avatar
Bernd Paysan committed
54
    :}
55
    locals-size @ extra-locals @ + r> !
56
    ['] endref, end-d
57
    ['] execute is end-d  ['] noop is endref,
58
    extra-locals off ;
59

60
: :}xt ( vtaddr u latest latestxt wid 0 a-addr1 u1 ... -- ) \ gforth close-brace-xt
Bernd Paysan's avatar
Bernd Paysan committed
61 62 63
    \G end a closure's locals declaration.  The closure will be allocated by
    \G the xt on the stack, so the closure's run-time stack effect is @code{(
    \G xt-alloc -- xt-closure}.
64
    \ run-time: ( xt size -- ... )
65 66
    [: swap execute ;] :}* ;

67
: :}d ( vtaddr u latest latestxt wid 0 a-addr1 u1 ... -- ) \ gforth close-brace-dictionary
Bernd Paysan's avatar
Bernd Paysan committed
68 69
    \G end a closure's locals declaration.  The closure will be allocated in
    \G the dictionary.
70 71
    ['] allocd :}* ;

72
: :}h ( vtaddr u latest latestxt wid 0 a-addr1 u1 ... -- ) \ gforth close-brace-heap
Bernd Paysan's avatar
Bernd Paysan committed
73 74
    \G end a closure's locals declaration.  The closure will be allocated on
    \G the heap.
75
    ['] alloch :}* ;
76

77 78
forth definitions

79 80 81
: push-locals ( list size -- )
    locals-size @ locals-sizes >stack  locals-size !
    locals-list @ locals-lists >stack  locals-list ! ;
82

83 84 85 86
: pop-locals ( -- )
    locals-lists stack> locals-list !
    locals-sizes stack> locals-size ! ;

87 88 89 90 91 92
locals-types definitions

: :}l ( vtaddr u latest latestxt wid 0 a-addr1 u1 ... -- ) \ gforth close-brace-locals
    \G end a closure's locals declaration.  The closure will be allocated on
    \G the local's stack.
    :}
93
    locals-size @ locals-list @ over 2>r  pop-locals
94
    [ 2 cells maxaligned ]L + locals-size +!
95
    get-current >r  0 warnings !@ >r  [ ' locals >body ]l set-current
96
    s" " nextname create-local locals-size @ locals,
97
    r> warnings !  r> set-current  2r> push-locals
98 99 100 101
    ['] noop end-d ;

forth definitions

102
: (closure-;]) ( closure-sys lastxt -- )
103
    >r r@ dup >namevt @ >vtextra !
104
    ['] does, set-optimizer  vt,
105
    postpone THEN
106
    orig? r> >namevt @ swap ! drop
107
    wrap! pop-locals ;
108

109 110 111 112 113 114 115
: 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 ;

116
: closure> ( body -- addr ) \ gforth-experimental closure-end
117
    \G create trampoline head
118
    dodoes: >l >l lp@ cell+ ;
119 120
: end-dclosure ( unravel-xt -- closure-sys )
    >r wrap@
Bernd Paysan's avatar
Bernd Paysan committed
121
    postpone lit >mark
122 123 124 125
    ]] closure> [[ r> execute ]] AHEAD [[
    action-of :-hook >r  ['] closure-:-hook is :-hook
    :noname
    r> is :-hook
126 127 128 129 130
    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
131
    ['] (closure-;]) colon-sys-xt-offset stick ;
132

133
: [{: ( -- vtaddr u latest latestxt wid 0 ) \ gforth-experimental start-closure
Bernd Paysan's avatar
Bernd Paysan committed
134 135 136
    \G starts a closure.  Closures first declare the locals frame they are
    \G going to use, and then the code that is executed with those locals.
    \G Closures end like quotations with a @code{;]}.  The locals declaration
137
    \G ends depending where the closure's locals are created.  At run-time, the
Bernd Paysan's avatar
Bernd Paysan committed
138 139 140 141 142
    \G closure is created as trampolin xt, and fills the values of its local
    \G frame from the stack.  At execution time of the xt, the local frame is
    \G copied to the locals stack, and used inside the closure's code.  After
    \G return, those values are removed from the locals stack, and not updated
    \G in the closure itself.
Bernd Paysan's avatar
Bernd Paysan committed
143
    [: ] drop ;] defstart
144
    #0. push-locals
145
    ['] end-dclosure is end-d  [: ]] lp> [[ ;] is endref,
146
    [ 2 cells maxaligned ]L extra-locals !
147
    postpone {:
148
; immediate compile-only
149

150
: <{: ( -- vtaddr u latest latestxt wid 0 ) \ gforth-experimental start-homelocation
151
    \G starts a home location
152
    #0. push-locals postpone {:
153 154
; immediate compile-only

155
: ;> ( -- ) \ gforth-experimental end-homelocation
156
    \G end using a home location
157
    pop-locals ]] laddr# [[ 0 , ]] lp> [[
158 159
; immediate compile-only

160 161 162 163 164 165 166
\ stack-based closures without name

: (;*]) ( -- )
    >r ] postpone endscope locals-list !
    r@ dup >namevt @ >vtextra !
    ['] does, set-optimizer
    vt, postpone THEN wrap!
167
    r> >namevt @ lit, ;
168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185

: n-closure> ( n vt -- xt )
    [ cell 4 = ] [IF]  0 >l  [THEN]
    swap >l dodoes: >l >l lp@ cell+ ;
: (n;]) ( xt -- )  (;*]) postpone n-closure> ;
: [n:l ( -- colon-sys ) ]] [: @ [[ ['] (n;]) colon-sys-xt-offset 2 + stick ;
    immediate restrict

: (n;]*) ( xt -- )  (;*]) [ 3 cells maxaligned ]L lit, compile,
    ]] >lp n-closure> lp> [[ ;
: ([n:*) ( xt -- colon-sys )
    ]] [: @ [[ ['] (n;]*) colon-sys-xt-offset 2 + stick ;
: [n:h ( -- colon-sys )  ['] alloch ([n:*) ; immediate restrict
: [n:d ( -- colon-sys )  ['] allocd ([n:*) ; immediate restrict

: d-closure> ( d vt -- xt )
    -rot 2>l dodoes: >l >l lp@ cell+ ;
: (d;]) ( xt -- )  (;*]) postpone d-closure> ;
Bernd Paysan's avatar
Bernd Paysan committed
186
: [d:l ( -- colon-sys ) ]] [: 2@ [[ ['] (d;]) colon-sys-xt-offset 2 + stick ;
187 188 189 190 191 192 193 194 195 196 197 198
    immediate restrict

: (d;]*) ( xt -- )  (;*]) [ 4 cells maxaligned ]L lit, compile,
    ]] >lp d-closure> lp> [[ ;
: ([d:*) ( xt -- colon-sys )
    ]] [: 2@ [[ ['] (d;]*) colon-sys-xt-offset 2 + stick ;
: [d:h ( -- colon-sys )  ['] alloch ([d:*) ; immediate restrict
: [d:d ( -- colon-sys )  ['] allocd ([d:*) ; immediate restrict

: f-closure> ( r vt -- xt )
    f>l dodoes: >l >l lp@ cell+ ;
: (f;]) ( xt -- )  (;*]) postpone f-closure> ;
Bernd Paysan's avatar
Bernd Paysan committed
199
: [f:l ( -- colon-sys ) ]] [: f@ [[ ['] (f;]) colon-sys-xt-offset 2 + stick ;
200 201 202 203 204 205 206 207 208
    immediate restrict

: (f;]*) ( xt -- )  (;*]) [ 2 cells float+ maxaligned ]L lit, compile,
    ]] >lp f-closure> lp> [[ ;
: ([f:*) ( xt -- colon-sys )
    ]] [: f@ [[ ['] (f;]*) colon-sys-xt-offset 2 + stick ;
: [f:h ( -- colon-sys )  ['] alloch ([f:*) ; immediate restrict
: [f:d ( -- colon-sys )  ['] allocd ([f:*) ; immediate restrict

209
false [IF]
210 211
    : foo [{: a f: b d: c xt: d :}d a . b f. c d. d ;] ;
    5 3.3e #1234. ' cr foo execute
212 213
    : homeloc <{: w^ a w^ b w^ c :}h a b c ;> ;
    1 2 3 homeloc >r ? ? ? r> free throw cr
Bernd Paysan's avatar
Bernd Paysan committed
214

215
    : A {: w^ k x1 x2 x3 xt: x4 xt: x5 | w^ B :} recursive
216
	k @ 0<= IF  x4 x5 +  ELSE
217
	    B k x1 x2 x3 action-of x4 [{: B k x1 x2 x3 x4 :}L
218 219 220
		-1 k +!
		k @ B @ x1 x2 x3 x4 A ;] dup B !
	    execute  THEN ;
221
    : man-or-boy? ( n -- n' ) [: 1 ;] [: -1 ;] 2dup swap [: 0 ;] A ;
Bernd Paysan's avatar
Bernd Paysan committed
222
    
223
    \ start with: gforth -l64M -r8M closures.fs
224 225
    \ start with: gforth-fast -l6G -r768M closures.fs if you want to go up to 26
    20 0 [DO] [i] dup . !time man-or-boy? . .time cr [LOOP]
226
[THEN]