prims2x.fs 56.4 KB
Newer Older
anton's avatar
anton committed
1 2
\ converts primitives to, e.g., C code 

Anton Ertl's avatar
Anton Ertl committed
3
\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2009,2010,2011,2013,2015,2017 Free Software Foundation, Inc.
anton's avatar
anton committed
4 5 6 7 8

\ 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
9
\ as published by the Free Software Foundation, either version 3
anton's avatar
anton committed
10 11 12 13 14 15 16 17
\ 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
18
\ along with this program. If not, see http://www.gnu.org/licenses/.
anton's avatar
anton committed
19 20


21 22
\ This is not very nice (hard limits, no checking, assumes 1 chars = 1).
\ And it grew even worse when it aged.
anton's avatar
anton committed
23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38

\ Optimizations:
\ superfluous stores are removed. GCC removes the superfluous loads by itself
\ TOS and FTOS can be kept in register( variable)s.
\ 
\ Problems:
\ The TOS optimization is somewhat hairy. The problems by example:
\ 1) dup ( w -- w w ): w=TOS; sp-=1; sp[1]=w; TOS=w;
\    The store is not superfluous although the earlier opt. would think so
\    Alternatively:    sp[0]=TOS; w=TOS; sp-=1; TOS=w;
\ 2) ( -- .. ): sp[0] = TOS; ... /* This additional store is necessary */
\ 3) ( .. -- ): ... TOS = sp[0]; /* as well as this load */
\ 4) ( -- ): /* but here they are unnecessary */
\ 5) Words that call NEXT themselves have to be done very carefully.
\
\ To do:
39
\ add the store optimization for doubles
anton's avatar
anton committed
40 41
\ regarding problem 1 above: It would be better (for over) to implement
\ 	the alternative
42 43 44 45 46 47 48 49 50 51
\ store optimization for combined instructions.

\ Design Uglyness:

\ - global state (values, variables) in connection with combined instructions.

\ - index computation is different for instruction-stream and the
\ stacks; there are two mechanisms for dealing with that
\ (stack-in-index-xt and a test for stack==instruction-stream); there
\ should be only one.
anton's avatar
anton committed
52

53

54 55 56
\ for backwards compatibility, jaw
require compat/strcomp.fs

57 58 59 60 61 62
[undefined] outfile-execute [if]
    : outfile-execute ( ... xt file-id -- ... )
	\ unsafe replacement
	outfile-id >r to outfile-id execute r> to outfile-id ;
[then]

63 64
warnings off

anton's avatar
anton committed
65 66 67 68
\ redefinitions of kernel words not present in gforth-0.6.1
: latestxt lastcfa @ ;
: latest last @ ;

69 70 71 72
[IFUNDEF] try
include startup.fs
[THEN]

73 74
: struct% struct ; \ struct is redefined in gray

75
warnings off
76
\ warnings on
77

jwilke's avatar
jwilke committed
78
include ./gray.fs
79
128 constant max-effect \ number of things on one side of a stack effect
80
4 constant max-stacks  \ the max. number of stacks (including inst-stream).
anton's avatar
anton committed
81 82
255 constant maxchar
maxchar 1+ constant eof-char
anton's avatar
anton committed
83 84
#tab constant tab-char
#lf constant nl-char
anton's avatar
anton committed
85

86 87 88
variable rawinput \ pointer to next character to be scanned
variable endrawinput \ pointer to the end of the input (the char after the last)
variable cookedinput \ pointer to the next char to be parsed
anton's avatar
anton committed
89
variable line \ line number of char pointed to by input
90 91
variable line-start \ pointer to start of current line (for error messages)
0 line !
anton's avatar
anton committed
92 93
2variable filename \ filename of original input file
0 0 filename 2!
94 95
2variable out-filename \ filename of the output file (for sync lines)
0 0 out-filename 2!
96 97
2variable f-comment
0 0 f-comment 2!
anton's avatar
anton committed
98
variable skipsynclines \ are sync lines ("#line ...") invisible to the parser?
99 100 101
skipsynclines on
variable out-nls \ newlines in output (for output sync lines)
0 out-nls !
102 103 104
variable store-optimization \ use store optimization?
store-optimization off

105 106 107 108 109
variable include-skipped-insts
\ does the threaded code for a combined instruction include the cells
\ for the component instructions (true) or only the cells for the
\ inline arguments (false)
include-skipped-insts off
anton's avatar
anton committed
110

111 112 113
2variable threaded-code-pointer-type \ type used for geninst etc.
s" Inst **" threaded-code-pointer-type 2!

114 115 116
variable immarg \ values for immediate arguments (to be used in IMM_ARG macros)
$12340000 immarg !

117 118 119 120 121 122 123 124 125
: th ( addr1 n -- addr2 )
    cells + ;

: holds ( addr u -- )
    \ like HOLD, but for a string
    tuck + swap 0 +do
	1- dup c@ hold
    loop
    drop ;
126

anton's avatar
anton committed
127
: insert-wordlist { c-addr u wordlist xt -- }
128 129 130 131 132 133
    \ adds name "addr u" to wordlist using defining word xt
    \ xt may cause additional stack effects
    get-current >r wordlist set-current
    c-addr u nextname xt execute
    r> set-current ;

anton's avatar
anton committed
134
: start ( -- addr )
135
 cookedinput @ ;
anton's avatar
anton committed
136 137

: end ( addr -- addr u )
138
 cookedinput @ over - ;
anton's avatar
anton committed
139

140 141 142 143 144 145
: print-error-line ( -- )
    \ print the current line and position
    line-start @ endrawinput @ over - 2dup nl-char scan drop nip ( start end )
    over - type cr
    line-start @ rawinput @ over - typewhite ." ^" cr ;

146 147 148 149
: print-error { addr u -- }
    filename 2@ type ." :" line @ 0 .r ." : " addr u type cr
    print-error-line ;

150 151
: ?print-error { f addr u -- }
    f ?not? if
152
	addr u ['] print-error stderr outfile-execute
153
	1 (bye) \ abort
154 155
    endif ;

156
: quote ( -- )
157
    '"' emit ;
158

159 160 161 162 163 164 165 166 167 168 169 170
\ count output lines to generate sync lines for output

: count-nls ( addr u -- )
    bounds u+do
	i c@ nl-char = negate out-nls +!
    loop ;

:noname ( addr u -- )
    2dup count-nls
    defers type ;
is type

171 172
variable output          \ xt ( -- ) of output word for simple primitives
variable output-combined \ xt ( -- ) of output word for combined primitives
anton's avatar
anton committed
173

174
struct%
175
    cell%    field stack-number \ the number of this stack
176
    cell% 2* field stack-pointer \ stackpointer name
177
    cell%    field stack-type \ name for default type of stack items
178
    cell%    field stack-in-index-xt \ ( in-size item -- in-index )
179
    cell%    field stack-access-transform \ ( nitem -- index )
180 181
end-struct stack%

182 183 184 185 186
struct%
 cell% 2* field item-name   \ name, excluding stack prefixes
 cell%    field item-stack  \ descriptor for the stack used, 0 is default
 cell%    field item-type   \ descriptor for the item type
 cell%    field item-offset \ offset in stack items, 0 for the deepest element
187
 cell%	  field item-first  \ true if this is the first occurence of the item
188 189 190 191 192 193 194 195 196 197
end-struct item%

struct%
    cell% 2* field type-c-name
    cell%    field type-stack \ default stack
    cell%    field type-size  \ size of type in stack items
    cell%    field type-fetch \ xt of fetch code generator ( item -- )
    cell%    field type-store \ xt of store code generator ( item -- )
end-struct type%

198 199 200 201 202 203 204 205 206 207 208 209 210
struct%
    cell%    field register-number
    cell%    field register-type \ pointer to type
    cell% 2* field register-name \ c name
end-struct register%

struct%
    cell% 2* field ss-registers  \ addr u; ss-registers[0] is TOS
                                 \ 0 means: use memory
    cell%    field ss-offset     \ stack pointer offset: sp[-offset] is TOS
end-struct ss% \ stack-state

struct%
211
    cell%              field state-enabled
212 213 214 215
    cell%              field state-number
    cell% max-stacks * field state-sss
end-struct state%

216 217
variable next-stack-number 0 next-stack-number !
create stacks max-stacks cells allot \ array of stacks
218 219 220 221
256 constant max-registers
create registers max-registers cells allot \ array of registers
variable nregisters 0 nregisters ! \ number of registers
variable next-state-number 0 next-state-number ! \ next state number
222

223 224 225 226 227 228
: stack-in-index ( in-size item -- in-index )
    item-offset @ - 1- ;

: inst-in-index ( in-size item -- in-index )
    nip dup item-offset @ swap item-type @ type-size @ + 1- ;

229 230
: make-stack ( addr-ptr u1 type "stack-name" -- )
    next-stack-number @ max-stacks < s" too many stacks" ?print-error
231
    create stack% %allot >r
232
    r@ stacks next-stack-number @ th !
233 234
    next-stack-number @ r@ stack-number !
    1 next-stack-number +!
235
    r@ stack-type !
236
    save-mem r@ stack-pointer 2! 
237 238 239
    ['] stack-in-index r@ stack-in-index-xt !
    ['] noop r@ stack-access-transform !
    rdrop ;
240

241
: map-stacks { xt -- }
242
    \ perform xt ( stack -- ) for all stacks
243 244 245 246 247
    next-stack-number @ 0 +do
	stacks i th @ xt execute
    loop ;

: map-stacks1 { xt -- }
248
    \ perform xt ( stack -- ) for all stacks except inst-stream
249 250 251 252
    next-stack-number @ 1 +do
	stacks i th @ xt execute
    loop ;

253
\ stack items
anton's avatar
anton committed
254

255 256
: init-item ( addr u addr1 -- )
    \ initialize item at addr1 with name addr u
257
    \ the stack prefix is removed by the stack-prefix
258 259 260
    dup item% %size erase
    item-name 2! ;

anton's avatar
anton committed
261 262 263 264 265 266
: map-items { addr end xt -- }
    \ perform xt for all items in array addr...end
    end addr ?do
	i xt execute
    item% %size +loop ;

267 268 269 270 271
\ types

: print-type-prefix ( type -- )
    body> >head name>string type ;

272
\ various variables for storing stuff of one primitive
anton's avatar
anton committed
273

274 275 276 277
struct%
    cell% 2* field prim-name
    cell% 2* field prim-wordset
    cell% 2* field prim-c-name
278
    cell% 2* field prim-c-name-orig \ for reprocessed prims, the original name
279 280 281 282
    cell% 2* field prim-doc
    cell% 2* field prim-c-code
    cell% 2* field prim-forth-code
    cell% 2* field prim-stack-string
anton's avatar
anton committed
283
    cell%    field prim-num            \ ordinal number
284
    cell%    field prim-items-wordlist \ unique items
285 286 287 288
    item% max-effect * field prim-effect-in
    item% max-effect * field prim-effect-out
    cell%    field prim-effect-in-end
    cell%    field prim-effect-out-end
289 290
    cell% max-stacks * field prim-stacks-in  \ number of in items per stack
    cell% max-stacks * field prim-stacks-out \ number of out items per stack
291
    cell% max-stacks * field prim-stacks-sync \ sync flag per stack
292 293
end-struct prim%

anton's avatar
anton committed
294 295 296 297 298
: make-prim ( -- prim )
    prim% %alloc { p }
    s" " p prim-doc 2! s" " p prim-forth-code 2! s" " p prim-wordset 2!
    p ;

anton's avatar
anton committed
299 300 301 302
0 value prim     \ in combined prims either combined or a part
0 value combined \ in combined prims the combined prim
variable in-part \ true if processing a part
 in-part off
303 304 305
0 value state-in  \ state on entering prim
0 value state-out \ state on exiting prim
0 value state-default  \ canonical state at bb boundaries
anton's avatar
anton committed
306

307 308 309 310 311 312 313 314
: prim-context ( ... p xt -- ... )
    \ execute xt with prim set to p
    prim >r
    swap to prim
    catch
    r> to prim
    throw ;

315 316 317
: prim-c-name-2! ( c-addr u -- )
    2dup prim prim-c-name 2! prim prim-c-name-orig 2! ;

anton's avatar
anton committed
318 319 320
1000 constant max-combined
create combined-prims max-combined cells allot
variable num-combined
321
variable part-num \ current part number during process-combined
anton's avatar
anton committed
322

323 324 325 326 327 328
: map-combined { xt -- }
    \ perform xt for all components of the current combined instruction
    num-combined @ 0 +do
	combined-prims i th @ xt execute
    loop ;

329 330 331
table constant combinations
  \ the keys are the sequences of pointers to primitives

anton's avatar
anton committed
332 333 334
create current-depth max-stacks cells allot
create max-depth     max-stacks cells allot
create min-depth     max-stacks cells allot
335

336 337 338
create sp-update-in max-stacks cells allot
\ where max-depth occured the first time
create max-depths max-stacks max-combined 1+ * cells allot
339 340 341
\ maximum depth at start of each part: array[parts] of array[stack]
create max-back-depths max-stacks max-combined 1+ * cells allot
\ maximun depth from end of the combination to the start of the each part
342 343 344 345

: s-c-max-depth ( nstack ncomponent -- addr )
    max-stacks * + cells max-depths + ;

346 347 348
: s-c-max-back-depth ( nstack ncomponent -- addr )
    max-stacks * + cells max-back-depths + ;

349 350 351
wordlist constant primitives

: create-prim ( prim -- )
anton's avatar
anton committed
352
    dup prim-name 2@ primitives ['] constant insert-wordlist ;
353 354 355 356 357 358 359 360 361

: stack-in ( stack -- addr )
    \ address of number of stack items in effect in
    stack-number @ cells prim prim-stacks-in + ;

: stack-out ( stack -- addr )
    \ address of number of stack items in effect out
    stack-number @ cells prim prim-stacks-out + ;

362 363 364
: stack-prim-stacks-sync ( stack -- addr )
    prim prim-stacks-sync swap stack-number @ th ;

365
\ global vars
anton's avatar
anton committed
366 367 368 369 370
variable c-line
2variable c-filename
variable name-line
2variable name-filename
2variable last-name-filename
pazsan's avatar
pazsan committed
371
Variable function-number 0 function-number !
pazsan's avatar
pazsan committed
372
Variable function-old 0 function-old !
373
: function-diff ( -- )
pazsan's avatar
pazsan committed
374 375 376 377 378
    ." GROUPADD(" function-number @ function-old @ - 0 .r ." )" cr
    function-number @ function-old ! ;
: forth-fdiff ( -- )
    function-number @ function-old @ - 0 .r ."  groupadd" cr
    function-number @ function-old ! ;
anton's avatar
anton committed
379 380 381 382 383 384 385 386 387

\ a few more set ops

: bit-equivalent ( w1 w2 -- w3 )
 xor invert ;

: complement ( set1 -- set2 )
 empty ['] bit-equivalent binary-set-operation ;

388 389 390
\ forward declaration for inst-stream (breaks cycle in definitions)
defer inst-stream-f ( -- stack )

391
\ stack access stuff
anton's avatar
anton committed
392

393
: normal-stack-access0 { n stack -- }
394
    \ n has the ss-offset already applied (see ...-access1)
395
    n stack stack-access-transform @ execute ." [" 0 .r ." ]" ;
396 397 398 399 400 401 402 403

: state-ss { stack state -- ss }
    state state-sss stack stack-number @ th @ ;

: stack-reg { n stack state -- reg }
    \ n is the index (TOS=0); reg is 0 if the access is to memory
    stack state state-ss ss-registers 2@ n u> if ( addr ) \ in ss-registers?
	n th @
404
    else
405
	drop 0
406
    endif ;
anton's avatar
anton committed
407

408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423
: .reg ( reg -- )
    register-name 2@ type ;

: stack-offset ( stack state -- n )
    \ offset for stack in state
    state-ss ss-offset @ ;

: normal-stack-access1 { n stack state -- }
    n stack state stack-reg ?dup-if
	.reg exit
    endif
    stack stack-pointer 2@ type
    n stack state stack-offset - stack normal-stack-access0 ;

: normal-stack-access ( n stack state -- )
    over inst-stream-f = if
424 425 426 427 428
	." IMM_ARG(" normal-stack-access1 ." ," immarg ? ." )"
	1 immarg +!
    else
	normal-stack-access1
    endif ;
429

430 431 432
: stack-depth { stack -- n }
    current-depth stack stack-number @ th @ ;

anton's avatar
anton committed
433
: part-stack-access { n stack -- }
434
    \ print _<stack><x>, x=inst-stream? n : maxdepth-currentdepth-n-1
anton's avatar
anton committed
435 436
    ." _" stack stack-pointer 2@ type
    stack stack-number @ { stack# }
437
    stack stack-depth n + { access-depth }
438 439 440 441 442 443 444
    stack inst-stream-f = if
	access-depth
    else
	combined prim-stacks-in stack# th @
	assert( dup max-depth stack# th @ = )
	access-depth - 1-
    endif
anton's avatar
anton committed
445 446
    0 .r ;

447 448 449 450 451
: part-stack-read { n stack -- }
    stack stack-depth n + ( ndepth )
    stack stack-number @ part-num @ s-c-max-depth @
\    max-depth stack stack-number @ th @ ( ndepth nmaxdepth )
    over <= if ( ndepth ) \ load from memory
452
	stack state-in normal-stack-access
453 454 455 456
    else
	drop n stack part-stack-access
    endif ;

457 458 459 460 461 462 463 464 465
: stack-diff ( stack -- n )
    \ in-out
    dup stack-in @ swap stack-out @ - ;

: part-stack-write { n stack -- }
    stack stack-depth n +
    stack stack-number @ part-num @ s-c-max-back-depth @
    over <= if ( ndepth )
	stack combined ['] stack-diff prim-context -
466
	stack state-out normal-stack-access
467 468 469
    else
	drop n stack part-stack-access
    endif ;
470 471 472 473 474 475

: stack-read ( n stack -- )
    \ print a stack access at index n of stack
    in-part @ if
	part-stack-read
    else
476
	state-in normal-stack-access
477 478 479
    endif ;

: stack-write ( n stack -- )
anton's avatar
anton committed
480 481
    \ print a stack access at index n of stack
    in-part @ if
482
	part-stack-write
anton's avatar
anton committed
483
    else
484
	state-out normal-stack-access
anton's avatar
anton committed
485 486
    endif ;

487
: item-in-index { item -- n }
488
    \ n is the index of item (in the in-effect)
489 490
    item item-stack @ dup >r stack-in @ ( in-size r:stack )
    item r> stack-in-index-xt @ execute ;
anton's avatar
anton committed
491

492 493 494
: item-stack-type-name ( item -- addr u )
    item-stack @ stack-type @ type-c-name 2@ ;

anton's avatar
anton committed
495
: fetch-single ( item -- )
anton's avatar
anton committed
496 497 498 499
    \ fetch a single stack item from its stack
    >r
    ." vm_" r@ item-stack-type-name type
    ." 2" r@ item-type @ print-type-prefix ." ("
500
    r@ item-in-index r@ item-stack @ stack-read ." ,"
anton's avatar
anton committed
501 502 503
    r@ item-name 2@ type
    ." );" cr
    rdrop ; 
anton's avatar
anton committed
504 505

: fetch-double ( item -- )
anton's avatar
anton committed
506 507 508 509 510
    \ fetch a double stack item from its stack
    >r
    ." vm_two"
    r@ item-stack-type-name type ." 2"
    r@ item-type @ print-type-prefix ." ("
511 512
    r@ item-in-index r@ item-stack @ 2dup stack-read
    ." , "                      -1 under+ stack-read
anton's avatar
anton committed
513 514 515
    ." , " r@ item-name 2@ type
    ." )" cr
    rdrop ;
anton's avatar
anton committed
516

517
: same-as-in? ( item -- f )
518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535
    \ f is true iff the offset and stack of item is the same as on input
    >r
    r@ item-stack @ stack-prim-stacks-sync @ if
	rdrop false exit
    endif
    r@ item-first @ if
	rdrop false exit
    endif
    r@ item-name 2@ prim prim-items-wordlist @ search-wordlist 0= abort" bug"
    execute @
    dup r@ =
    if \ item first appeared in output
	drop false
    else
	dup  item-stack  @ r@ item-stack  @ = 
	swap item-offset @ r@ item-offset @ = and
    endif
    rdrop ;
anton's avatar
anton committed
536

537
: item-out-index ( item -- n )
538
    \ n is the index of item (in the out-effect)
539
    >r r@ item-stack @ stack-out @ r> item-offset @ - 1- ;
pazsan's avatar
pazsan committed
540

anton's avatar
anton committed
541
: really-store-single ( item -- )
anton's avatar
anton committed
542 543 544 545 546
    >r
    ." vm_"
    r@ item-type @ print-type-prefix ." 2"
    r@ item-stack-type-name type ." ("
    r@ item-name 2@ type ." ,"
547
    r@ item-out-index r@ item-stack @ stack-write ." );"
anton's avatar
anton committed
548
    rdrop ;
anton's avatar
anton committed
549

550 551 552
: store-single { item -- }
    item item-stack @ { stack }
    store-optimization @ in-part @ 0= and item same-as-in? and
553 554
    item item-in-index  stack state-in  stack-reg       \  in reg/mem
    item item-out-index stack state-out stack-reg = and \ out reg/mem
555 556 557
    0= if
	item really-store-single cr
    endif ;
anton's avatar
anton committed
558 559 560 561

: store-double ( item -- )
\ !! store optimization is not performed, because it is not yet needed
 >r
562 563 564 565
 ." vm_"
 r@ item-type @ print-type-prefix ." 2two"
 r@ item-stack-type-name type ." ("
 r@ item-name 2@ type ." , "
566 567
 r@ item-out-index r@ item-stack @ 2dup stack-write
 ." , "                       -1 under+ stack-write
anton's avatar
anton committed
568
 ." )" cr
anton's avatar
anton committed
569 570
 rdrop ;

571 572
: single ( -- xt1 xt2 n )
    ['] fetch-single ['] store-single 1 ;
anton's avatar
anton committed
573

574 575
: double ( -- xt1 xt2 n )
    ['] fetch-double ['] store-double 2 ;
anton's avatar
anton committed
576 577 578 579 580

: s, ( addr u -- )
\ allocate a string
 here swap dup allot move ;

581 582 583 584 585 586 587 588 589 590 591 592 593 594
wordlist constant prefixes

: declare ( addr "name" -- )
\ remember that there is a stack item at addr called name
 create , ;

: !default ( w addr -- )
    dup @ if
	2drop \ leave nonzero alone
    else
	!
    endif ;

: create-type { addr u xt1 xt2 n stack -- } ( "prefix" -- )
595 596 597 598 599 600 601 602 603 604
    \ describes a type
    \ addr u specifies the C type name
    \ stack effect entries of the type start with prefix
    create type% %allot >r
    addr u save-mem r@ type-c-name 2!
    xt1   r@ type-fetch !
    xt2   r@ type-store !
    n     r@ type-size !
    stack r@ type-stack !
    rdrop ;
anton's avatar
anton committed
605

606
: type-prefix ( addr u xt1 xt2 n stack "prefix" -- )
607 608
    get-current >r prefixes set-current
    create-type r> set-current
609 610 611 612 613
does> ( item -- )
    \ initialize item
    { item typ }
    typ item item-type !
    typ type-stack @ item item-stack !default
614
    item item-name 2@ prim prim-items-wordlist @ search-wordlist 0= if
615 616 617
	item item-name 2@ nextname item declare
	item item-first on
	\ typ type-c-name 2@ type space type  ." ;" cr
618 619
    else
	drop
620
	item item-first off
621
    endif ;
anton's avatar
anton committed
622

623 624 625 626 627 628 629 630 631 632
: execute-prefix ( item addr1 u1 -- )
    \ execute the word ( item -- ) associated with the longest prefix
    \ of addr1 u1
    0 swap ?do
	dup i prefixes search-wordlist
	if \ ok, we have the type ( item addr1 xt )
	    nip execute
	    UNLOOP EXIT
	endif
	-1 s+loop
633 634
	\ we did not find a type, abort
	abort
635
    false s" unknown prefix" ?print-error ;
anton's avatar
anton committed
636 637

: declaration ( item -- )
638
    dup item-name 2@ execute-prefix ;
anton's avatar
anton committed
639

anton's avatar
anton committed
640 641 642 643
: declaration-list ( addr1 addr2 -- )
    ['] declaration map-items ;

: declarations ( -- )
644
 wordlist dup prim prim-items-wordlist ! set-current
645 646
 prim prim-effect-in prim prim-effect-in-end @ declaration-list
 prim prim-effect-out prim prim-effect-out-end @ declaration-list ;
anton's avatar
anton committed
647

648 649
Variable maybe-unused

650 651
: print-declaration { item -- }
    item item-first @ if
652
	maybe-unused @ IF  ." MAYBE_UNUSED "  THEN
653 654 655 656 657
	item item-type @ type-c-name 2@ type space
	item item-name 2@ type ." ;" cr
    endif ;

: print-declarations ( -- )
658
    maybe-unused on
659
    prim prim-effect-in  prim prim-effect-in-end  @ ['] print-declaration map-items
660
    maybe-unused off
661
    prim prim-effect-out prim prim-effect-out-end @ ['] print-declaration map-items ;
662
    
663
: stack-prefix ( stack "prefix" -- )
664
    get-current >r prefixes set-current
665
    name tuck nextname create ( stack length ) 2,
666
    r> set-current
667 668 669 670 671
does> ( item -- )
    2@ { item stack prefix-length }
    item item-name 2@ prefix-length /string item item-name 2!
    stack item item-stack !
    item declaration ;
anton's avatar
anton committed
672

673 674 675 676 677 678 679
: set-prim-stacks-sync ( stack -- )
    stack-prim-stacks-sync on ;

: clear-prim-stacks-sync ( stack -- )
    stack-prim-stacks-sync off ;


680 681 682 683 684
get-current prefixes set-current
: ... ( item -- )
    \ this "prefix" ensures that the appropriate stack is synced with memory
    dup item-name 2@ s" ..." str= 0= abort" '...' must end the item name"
    item-stack @ dup if
685
	set-prim-stacks-sync
686
    else \ prefixless "..." syncs all stacks
687
	drop ['] set-prim-stacks-sync map-stacks1
688 689 690 691
    endif ;
set-current

create ...-item ( -- addr ) \ just used for letting stack-prefixes work on it
692
item% %allot drop           \ stores the stack temporarily until used by ...
693 694 695 696 697 698 699 700 701 702 703 704

: init-item1 ( addr1 addr u -- addr2 )
    \ initialize item at addr1 with name addr u, next item is at addr2
    \ !! make sure that any mention of "..." is only stack-prefixed
    2dup s" ..." search nip nip if ( addr1 addr u )
	0 ...-item item-stack ! \ initialize to prefixless
	2dup ...-item item-name 2!
	...-item rot rot execute-prefix ( addr1 )
    else
	2 pick init-item item% %size +
    endif ;

705
\ types pointed to by stacks for use in combined prims
706
\ !! output-c-combined shouldn't use these names!
707 708 709
: stack-type-name ( addr u "name" -- )
    single 0 create-type ;

710 711 712
wordlist constant type-names \ this is here just to meet the requirement
                    \ that a type be a word; it is never used for lookup

713 714 715 716 717 718 719
: define-type ( addr u -- xt )
    \ define single type with name addr u, without stack
    get-current type-names set-current >r
    2dup nextname stack-type-name
    r> set-current
    latestxt ;

720 721 722 723 724
: stack ( "name" "stack-pointer" "type" -- )
    \ define stack
    name { d: stack-name }
    name { d: stack-pointer }
    name { d: stack-type }
725 726
    stack-type define-type
    stack-pointer rot >body stack-name nextname make-stack ;
727 728

stack inst-stream IP Cell
anton's avatar
anton committed
729
' inst-in-index inst-stream stack-in-index-xt !
730
' inst-stream <is> inst-stream-f
anton's avatar
anton committed
731 732
\ !! initialize stack-in and stack-out

733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766
\ registers

: make-register ( type addr u -- )
    \ define register with type TYPE and name ADDR U.
    nregisters @ max-registers < s" too many registers" ?print-error
    2dup nextname create register% %allot >r
    r@ register-name 2!
    r@ register-type !
    nregisters @ r@ register-number !
    1 nregisters +!
    rdrop ;

: register ( "name" "type" -- )
    \ define register
    name { d: reg-name }
    name { d: reg-type }
    reg-type define-type >body
    reg-name make-register ;

\ stack-states

: stack-state ( a-addr u uoffset "name" -- )
    create ss% %allot >r
    r@ ss-offset !
    r@ ss-registers 2!
    rdrop ;

0 0 0 stack-state default-ss

\ state

: state ( "name" -- )
    \ create a state initialized with default-sss
    create state% %allot { s }
767
    s state-enabled on
768 769 770 771 772
    next-state-number @ s state-number ! 1 next-state-number +!
    max-stacks 0 ?do
	default-ss s state-sss i th !
    loop ;

773 774 775 776 777 778
: state-disable ( state -- )
    state-enabled off ;

: state-enabled? ( state -- f )
    state-enabled @ ;

anton's avatar
anton committed
779
: .state ( state -- )
780
    body> >name .name ;
anton's avatar
anton committed
781

782 783 784
: set-ss ( ss stack state -- )
    state-sss swap stack-number @ th ! ;

anton's avatar
anton committed
785 786 787 788
\ offset computation
\ the leftmost (i.e. deepest) item has offset 0
\ the rightmost item has the highest offset

789 790 791 792 793 794
: compute-offset { item xt -- }
    \ xt specifies in/out; update stack-in/out and set item-offset
    item item-type @ type-size @
    item item-stack @ xt execute dup @ >r +!
    r> item item-offset ! ;

anton's avatar
anton committed
795 796 797 798 799
: compute-offset-in ( addr1 addr2 -- )
    ['] stack-in compute-offset ;

: compute-offset-out ( addr1 addr2 -- )
    ['] stack-out compute-offset ;
800

anton's avatar
anton committed
801
: compute-offsets ( -- )
anton's avatar
anton committed
802 803
    prim prim-stacks-in  max-stacks cells erase
    prim prim-stacks-out max-stacks cells erase
804 805
    prim prim-effect-in  prim prim-effect-in-end  @ ['] compute-offset-in  map-items
    prim prim-effect-out prim prim-effect-out-end @ ['] compute-offset-out map-items
806 807
    inst-stream stack-out @ 0= s" # can only be on the input side" ?print-error ;

808 809
: init-simple { prim -- }
    \ much of the initialization is elsewhere
810
    ['] clear-prim-stacks-sync map-stacks ;
811

812 813
: process-simple ( -- )
    prim prim { W^ key } key cell
anton's avatar
anton committed
814
    combinations ['] constant insert-wordlist
815
    declarations compute-offsets
anton's avatar
anton committed
816
    output @ execute ;
817

818 819 820 821 822 823 824 825 826
: stack-state-items ( stack state -- n )
    state-ss ss-registers 2@ nip ;

: unused-stack-items { stack -- n-in n-out }
    \ n-in  are the stack items in state-in  not used    by prim
    \ n-out are the stack items in state-out not written by prim
    stack state-in  stack-state-items stack stack-in  @ - 0 max
    stack state-out stack-state-items stack stack-out @ - 0 max ;

827 828 829 830 831 832 833 834
: spill-stack-items { stack -- u }
    \ there are u items to spill in stack
    stack unused-stack-items
    stack stack-prim-stacks-sync @ if
	drop 0
    endif
    swap - ;

835 836 837 838
: spill-stack { stack -- }
    \ spill regs of state-in that are not used by prim and are not in state-out
    stack state-in stack-offset { offset }
    stack state-in stack-state-items ( items )
839
    dup stack spill-stack-items + +do
840 841 842 843 844
	\ loop through the bottom items
	stack stack-pointer 2@ type
	i offset - stack normal-stack-access0 ."  = "
	i stack state-in normal-stack-access1 ." ;" cr
    loop ;
845

846 847 848
: spill-state ( -- )
    ['] spill-stack map-stacks1 ;

849 850 851 852 853 854 855 856
: fill-stack-items { stack -- u }
    \ there are u items to fill in stack
    stack unused-stack-items
    stack stack-prim-stacks-sync @ if
	swap drop 0 swap
    endif
    - ;

857 858 859
: fill-stack { stack -- }
    stack state-out stack-offset { offset }
    stack state-out stack-state-items ( items )
860
    dup stack fill-stack-items + +do
861 862 863 864 865
	\ loop through the bottom items
	i stack state-out normal-stack-access1 ."  = "
	stack stack-pointer 2@ type
	i offset - stack normal-stack-access0 ." ;" cr
    loop ;
anton's avatar
anton committed
866

867
: fill-state ( -- )
868
    \ !! inst-stream for prefetching?
869
    ['] fill-stack map-stacks1 ;
870 871

: fetch ( addr -- )
872
    dup item-type @ type-fetch @ execute ;
anton's avatar
anton committed
873 874

: fetches ( -- )
875
    prim prim-effect-in prim prim-effect-in-end @ ['] fetch map-items ;
876

877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909
: reg-reg-move ( reg-from reg-to -- )
    2dup = if
	2drop
    else
	.reg ."  = " .reg ." ;" cr
    endif ;

: stack-bottom-reg { n stack state -- reg }
    stack state stack-state-items n - 1- stack state stack-reg ;

: stack-moves { stack -- }
    \ generate moves between registers in state-in/state-out that are
    \ not spilled or consumed/produced by prim.
    \ !! this works only for a simple stack cache, not e.g., for
    \ rotating stack caches, or registers shared between stacks (the
    \ latter would also require a change in interface)
    \ !! maybe place this after NEXT_P1?
    stack unused-stack-items 2dup < if ( n-in n-out )
	\ move registers from 0..n_in-1 to n_out-n_in..n_out-1
	over - { diff } ( n-in )
	-1 swap 1- -do
	    i stack state-in stack-bottom-reg ( reg-from )
	    i diff + stack state-out stack-bottom-reg reg-reg-move
	1 -loop
    else
	\ move registers from n_in-n_out..n_in-1 to 0..n_out-1
	swap over - { diff } ( n-out )
	0 +do
	    i diff + stack state-in stack-bottom-reg ( reg-from )
	    i stack state-out stack-bottom-reg reg-reg-move
	loop
    endif ;

910 911 912 913 914 915
: stack-update-transform ( n1 stack -- n2 )
    \ n2 is the number by which the stack pointer should be
    \ incremented to pop n1 items
    stack-access-transform @ dup >r execute
    0 r> execute - ;

916 917
: update-stack-pointer { stack n -- }
    n if \ this check is not necessary, gcc would do this for us
918
	stack inst-stream = if
919
	    ." INC_IP(" n 0 .r ." );" cr
920
	else
921
	    stack stack-pointer 2@ type ."  += "
922
	    n stack stack-update-transform 0 .r ." ;" cr
923
	endif
924 925 926 927 928
    endif ;

: stack-pointer-update { stack -- }
    \ and moves
    \ stacks grow downwards
929
\    ." /* stack pointer update " stack stack-pointer 2@ type ."  */" cr
930
    stack stack-prim-stacks-sync @ if
931
\	." /* synced "  stack stack-in ? stack stack-out ? stack state-in  stack-offset . ." */" cr
932 933 934 935
	stack stack-in @
	stack state-in  stack-offset -
	stack swap update-stack-pointer
    else
936
\	." /* unsynced "  stack stack-in ? stack stack-out ? ." */" cr
937 938 939 940 941 942
	stack stack-diff ( in-out )
	stack state-in  stack-offset -
	stack state-out stack-offset + ( [in-in_offset]-[out-out_offset] )
	stack swap update-stack-pointer
	stack stack-moves
    endif ;
943

anton's avatar
anton committed
944
: stack-pointer-updates ( -- )
945
    ['] stack-pointer-update map-stacks ;
anton's avatar
anton committed
946

947
: stack-pointer-update2 { stack -- }
948
\    ." /* stack pointer update2 " stack stack-pointer 2@ type ."  */" cr
949 950 951 952 953 954 955 956 957 958
    stack stack-prim-stacks-sync @ if
	stack state-out stack-offset
	stack stack-out @ -
	stack swap update-stack-pointer
    endif ;

: stack-pointer-updates2 ( -- )
    \ update stack pointers after C code, where necessary
    ['] stack-pointer-update2 map-stacks ;

anton's avatar
anton committed
959 960 961
: store ( item -- )
\ f is true if the item should be stored
\ f is false if the store is probably not necessary
962
 dup item-type @ type-store @ execute ;
anton's avatar
anton committed
963 964

: stores ( -- )
965
    prim prim-effect-out prim prim-effect-out-end @ ['] store map-items ;
966

967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994
: print-debug-arg { item -- }
    ." fputs(" quote space item item-name 2@ type ." =" quote ." , vm_out); "
    ." printarg_" item item-type @ print-type-prefix
    ." (" item item-name 2@ type ." );" cr ;
    
: print-debug-args ( -- )
    ." #ifdef VM_DEBUG" cr
    ." if (vm_debug) {" cr
    prim prim-effect-in prim prim-effect-in-end @ ['] print-debug-arg map-items
\    ." fputc('\n', vm_out);" cr
    ." }" cr
    ." #endif" cr ;

: print-debug-result { item -- }
    item item-first @ if
	item print-debug-arg
    endif ;

: print-debug-results ( -- )
    cr
    ." #ifdef VM_DEBUG" cr
    ." if (vm_debug) {" cr
    ." fputs(" quote ."  -- " quote ." , vm_out); "
    prim prim-effect-out prim prim-effect-out-end @ ['] print-debug-result map-items
    ." fputc('\n', vm_out);" cr
    ." }" cr
    ." #endif" cr ;

995 996 997 998 999 1000
: output-super-end ( -- )
    prim prim-c-code 2@ s" SET_IP" search if
	." SUPER_END;" cr
    endif
    2drop ;

1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011

defer output-nextp0
:noname ( -- )
    ." NEXT_P0;" cr ;
is output-nextp0

defer output-nextp1
:noname ( -- )
    ." NEXT_P1;" cr ;
is output-nextp1

1012 1013 1014 1015 1016 1017
: output-nextp2 ( -- )
    ." NEXT_P2;" cr ;

variable tail-nextp2 \ xt to execute for printing NEXT_P2 in INST_TAIL
' output-nextp2 tail-nextp2 !

1018
: output-label2 ( -- )
1019
    ." LABEL2(" prim prim-c-name 2@ type ." )" cr
1020
    .\" NAME1(\"l2-" prim prim-c-name 2@ type .\" \")" cr
1021 1022
    ." NEXT_P1_5;" cr
    ." LABEL3(" prim prim-c-name 2@ type ." )" cr
1023
    .\" NAME1(\"l3-" prim prim-c-name 2@ type .\" \")" cr
1024
    ." DO_GOTO;" cr ;
1025 1026 1027

: output-c-tail1 { xt -- }
    \ the final part of the generated C code, with xt printing LABEL2 or not.
1028
    output-super-end
1029
    print-debug-results
1030
    output-nextp1
1031
    stack-pointer-updates2
1032
    stores
1033
    fill-state 
1034
    xt execute ;
1035

1036 1037 1038 1039 1040 1041 1042 1043 1044 1045
: output-c-vm-jump-tail ( -- )
    \ !! this functionality not yet implemented for superinstructions
    output-super-end
    print-debug-results
    stores
    fill-state 
    ." LABEL2(" prim prim-c-name 2@ type ." )" cr
    ." LABEL3(" prim prim-c-name 2@ type ." )" cr
    ." DO_GOTO;" cr ;

1046 1047 1048
: output-c-tail1-no-stores { xt -- }
    \ the final part of the generated C code for combinations
    output-super-end
1049
    output-nextp1
1050
    fill-state 
1051
    xt execute ;
1052 1053

: output-c-tail ( -- )
1054
    tail-nextp2 @ output-c-tail1 ;
1055

1056
: output-c-tail2 ( -- )
1057 1058 1059 1060 1061
    prim prim-c-code 2@ s" VM_JUMP(" search nip nip if
	output-c-vm-jump-tail
    else
	['] output-label2 output-c-tail1
    endif ;
1062 1063

: output-c-tail-no-stores ( -- )
1064
    tail-nextp2 @ output-c-tail1-no-stores ;
1065 1066

: output-c-tail2-no-stores ( -- )
1067
    prim prim-c-code 2@ s" VM_JUMP(" search nip nip abort" Currently VM_JUMP is not supported in static superinstructions"
1068
    ['] output-label2 output-c-tail1-no-stores ;
1069

1070
: type-c-code ( c-addr u xt -- )
anton's avatar
anton committed
1071
    \ like TYPE, but replaces "INST_TAIL;" with tail code produced by xt
1072
    { xt }
1073 1074
    ." {" cr
    ." #line " c-line @ . quote c-filename 2@ type quote cr
1075
    begin ( c-addr1 u1 )
anton's avatar
anton committed
1076
	2dup s" INST_TAIL;" search
1077 1078
    while ( c-addr1 u1 c-addr3 u3 )
	2dup 2>r drop nip over - type
1079
	xt execute
anton's avatar
anton committed
1080
	2r> 10 /string
1081 1082
	\ !! resync #line missing
    repeat
1083 1084 1085
    2drop type
    ." #line " out-nls @ 2 + . quote out-filename 2@ type quote cr
    ." }" cr ;
1086

1087
: print-entry ( -- )
anton's avatar
anton committed
1088
    ." LABEL(" prim prim-c-name 2@ type ." )" ;
pazsan's avatar
pazsan committed
1089 1090 1091 1092 1093 1094 1095

: prim-type ( addr u -- )
    \ print out a primitive, but avoid "*/"
    2dup s" */" search  nip nip  IF
	bounds ?DO  I c@ dup '* = IF  drop 'x  THEN  emit  LOOP
    ELSE  type  THEN ;

1096
: output-c ( -- )
pazsan's avatar
pazsan committed
1097
    print-entry ."  /* " prim prim-name 2@ prim-type
anton's avatar
anton committed
1098 1099
    ."  ( " prim prim-stack-string 2@ type ." ) "
    state-in .state ." -- " state-out .state ."  */" cr
1100 1101 1102 1103 1104
    ." /* " prim prim-doc 2@ type ."  */" cr
    ." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging
    ." {" cr
    ." DEF_CA" cr
    print-declarations
1105
    output-nextp0
1106
    spill-state
1107 1108 1109 1110 1111 1112 1113
    fetches
    print-debug-args
    stack-pointer-updates
    prim prim-c-code 2@ ['] output-c-tail type-c-code
    output-c-tail2
    ." }" cr
    cr
anton's avatar
anton committed
1114 1115
;

1116 1117
: disasm-arg { item -- }
    item item-stack @ inst-stream = if
1118 1119 1120 1121 1122
	." {" cr
	item print-declaration
	item fetch
	item print-debug-arg
	." }" cr
1123 1124 1125
    endif ;

: disasm-args ( -- )
1126
    prim prim-effect-in prim prim-effect-in-end @ ['] disasm-arg map-items ;
1127 1128 1129

: output-disasm ( -- )
    \ generate code for disassembling VM instructions
anton's avatar
anton committed
1130
    ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr
1131
    ."   fputs(" quote prim prim-name 2@ type quote ." , vm_out);" cr
1132 1133
    disasm-args
    ."   ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr
1134 1135
    ."   goto _endif_;" cr
    ." }" cr ;
1136

1137 1138
: output-profile ( -- )
    \ generate code for postprocessing the VM block profile stuff
anton's avatar
anton committed
1139
    ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr
1140
    ."   add_inst(b, " quote prim prim-name 2@ type quote ." );" cr
1141 1142 1143 1144
    ."   ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr
    prim prim-c-code 2@  s" SET_IP"    search nip nip
    prim prim-c-code 2@  s" SUPER_END" search nip nip or if
	."   return;" cr
1145 1146
    else
	."   goto _endif_;" cr
1147
    endif
1148
    ." }" cr ;
1149

1150 1151 1152 1153 1154
: output-profile-part ( p )
    ."   add_inst(b, " quote
    prim-name 2@ type
    quote ." );" cr ;
    
1155 1156 1157
: output-profile-combined ( -- )
    \ generate code for postprocessing the VM block profile stuff
    ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr
1158
    ['] output-profile-part map-combined
1159 1160 1161 1162 1163 1164 1165 1166 1167
    ."   ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr
    combined-prims num-combined @ 1- th @ prim-c-code 2@  s" SET_IP"    search nip nip
    combined-prims num-combined @ 1- th @ prim-c-code 2@  s" SUPER_END" search nip nip or if
	."   return;" cr
    else
	."   goto _endif_;" cr
    endif
    ." }" cr ;

1168 1169 1170 1171
: prim-branch? { prim -- f }
    \ true if prim is a branch or super-end
    prim prim-c-code 2@  s" SET_IP" search nip nip 0<> ;

1172 1173
: output-superend ( -- )
    \ output flag specifying whether the current word ends a dynamic superinst
1174 1175
    prim prim-branch?
    prim prim-c-code 2@  s" SUPER_END" search nip nip 0<> or
1176
    prim prim-c-code 2@  s" SUPER_CONTINUE" search nip nip 0= and
pazsan's avatar
pazsan committed
1177
    negate 0 .r ." , /* " prim prim-name 2@ prim-type ."  */" cr ;
1178

1179 1180 1181 1182 1183 1184 1185
: gen-arg-parm { item -- }
    item item-stack @ inst-stream = if
	." , " item item-type @ type-c-name 2@ type space
	item item-name 2@ type
    endif ;

: gen-args-parm ( -- )
1186
    prim prim-effect-in prim prim-effect-in-end @ ['] gen-arg-parm map-items ;
1187 1188 1189 1190 1191 1192 1193 1194

: gen-arg-gen { item -- }
    item item-stack @ inst-stream = if
	."   genarg_" item item-type @ print-type-prefix
        ." (ctp, " item item-name 2@ type ." );" cr
    endif ;

: gen-args-gen ( -- )
1195
    prim prim-effect-in prim prim-effect-in-end @ ['] gen-arg-gen map-items ;
1196 1197 1198

: output-gen ( -- )
    \ generate C code for generating VM instructions
1199 1200
    ." void gen_" prim prim-c-name 2@ type ." ("
    threaded-code-pointer-type 2@ type ." ctp" gen-args-parm ." )" cr
1201
    ." {" cr
1202
    ."   gen_inst(ctp, " function-number @ 0 .r ." );" cr
1203
    gen-args-gen
anton's avatar
anton committed
1204
    ." }" cr ;
1205

1206 1207
: stack-used? { stack -- f }
    stack stack-in @ stack stack-out @ or 0<> ;
1208

pazsan's avatar
pazsan committed
1209
: output-funclabel ( -- )
1210
  ." &I_" prim prim-c-name 2@ type ." ," cr ;
pazsan's avatar
pazsan committed
1211 1212

: output-forthname ( -- )
1213
  '" emit prim prim-name 2@ type '" emit ." ," cr ;
pazsan's avatar
pazsan committed
1214

1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228
\  : output-c-func ( -- )
\  \ used for word libraries
\      ." Cell * I_" prim prim-c-name 2@ type ." (Cell *SP, Cell **FP)      /* " prim prim-name 2@ type
\      ."  ( " prim prim-stack-string 2@ type ."  ) */" cr
\      ." /* " prim prim-doc 2@ type ."  */" cr
\      ." NAME(" quote prim prim-name 2@ type quote ." )" cr
\      \ debugging
\      ." {" cr
\      print-declarations
\      \ !! don't know what to do about that
\      inst-stream  stack-used? IF ." Cell *ip=IP;" cr THEN
\      data-stack   stack-used? IF ." Cell *sp=SP;" cr THEN
\      fp-stack     stack-used? IF ." Cell *fp=*FP;" cr THEN
\      return-stack stack-used? IF ." Cell *rp=*RP;" cr THEN
1229
\      spill-state
1230 1231 1232 1233 1234 1235 1236 1237
\      fetches
\      stack-pointer-updates
\      fp-stack   stack-used? IF ." *FP=fp;" cr THEN
\      ." {" cr
\      ." #line " c-line @ . quote c-filename 2@ type quote cr
\      prim prim-c-code 2@ type
\      ." }" cr
\      stores
1238
\      fill-state
1239 1240 1241
\      ." return (sp);" cr
\      ." }" cr
\      cr ;
pazsan's avatar
pazsan committed
1242

1243
: output-label ( -- )  
1244
    ." INST_ADDR(" prim prim-c-name 2@ type ." )," cr ;
anton's avatar
anton committed
1245

Anton Ertl's avatar
Anton Ertl committed
1246 1247 1248 1249
: output-alias ( -- )
    name-line @ 1- . 0 . ." #loc " name-filename 2@ type space
    \ I don't know why the "1-" above is necessary, but it works
    ." Primitive " prim prim-name 2@ type cr ;
anton's avatar
anton committed
1250

1251 1252 1253
defer output-c-prim-num ( -- )

:noname ( -- )
1254
    ." N_" prim prim-c-name 2@ type ." ," cr ;
1255
is output-c-prim-num
1256

1257
: output-forth ( -- )  
1258
    prim prim-forth-code @ 0=
pazsan's avatar
pazsan committed
1259
    IF    	\ output-alias
jwilke's avatar
jwilke committed
1260 1261
	\ this is bad for ec: an alias is compiled if tho word does not exist!
	\ JAW
1262 1263 1264
    ELSE  ." : " prim prim-name 2@ type ."   ( "
	prim prim-stack-string 2@ type ." )" cr
	prim prim-forth-code 2@ type cr
pazsan's avatar
pazsan committed
1265
    THEN ;
1266

anton's avatar
anton committed
1267
: output-tag-file ( -- )
pazsan's avatar
pazsan committed
1268
    name-filename 2@ last-name-filename 2@ compare if
anton's avatar
anton committed
1269 1270 1271 1272 1273 1274 1275 1276
	name-filename 2@ last-name-filename 2!
	#ff emit cr
	name-filename 2@ type
	." ,0" cr
    endif ;

: output-tag ( -- )
    output-tag-file
1277
    prim prim-name 2@ 1+ type
anton's avatar
anton committed
1278
    127 emit
1279
    prim prim-name 2@ type
anton's avatar
anton committed
1280
    1 emit
1281
    name-line @ 1- 0 .r
anton's avatar
anton committed
1282 1283
    ." ,0" cr ;

pazsan's avatar
pazsan committed
1284 1285 1286 1287 1288
: output-vi-tag ( -- )
    name-filename 2@ type #tab emit
    prim prim-name 2@ type #tab emit
    ." /^" prim prim-name 2@ type ."  *(/" cr ;

1289 1290
[IFDEF] documentation
: register-doc ( -- )
anton's avatar
anton committed
1291
    prim prim-name 2@ documentation ['] create insert-wordlist
1292 1293 1294 1295
    prim prim-name 2@ 2,
    prim prim-stack-string 2@ condition-stack-effect 2,
    prim prim-wordset 2@ 2,
    prim prim-c-name 2@ condition-pronounciation 2,
anton's avatar
anton committed
1296
    prim prim-doc 2@ 2, ;
1297
[THEN]
1298

anton's avatar
anton committed
1299

1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363
\ combining instructions

\ The input should look like this:

\ lit_+ = lit +

\ The output should look like this:

\  I_lit_+:
\  {
\  DEF_CA
\  Cell _x_ip0;
\  Cell _x_sp0;
\  Cell _x_sp1;
\  NEXT_P0;
\  _x_ip0 = (Cell) IPTOS;
\  _x_sp0 = (Cell) spTOS;
\  INC_IP(1);
\  /* sp += 0; */
\  /* lit ( #w -- w ) */
\  /*  */
\  NAME("lit")
\  {
\  Cell w;
\  w = (Cell) _x_ip0;
\  #ifdef VM_DEBUG
\  if (vm_debug) {
\  fputs(" w=", vm_out); printarg_w (w);
\  fputc('\n', vm_out);
\  }
\  #endif
\  {
\  #line 136 "./prim"
\  }
\  _x_sp1 = (Cell)w;
\  }
\  I_plus:	/* + ( n1 n2 -- n ) */
\  /*  */
\  NAME("+")
\  {
\  DEF_CA
\  Cell n1;
\  Cell n2;
\  Cell n;
\  NEXT_P0;
\  n1 = (Cell) _x_sp0;
\  n2 = (Cell) _x_sp1;
\  #ifdef VM_DEBUG
\  if (vm_debug) {
\  fputs(" n1=", vm_out); printarg_n (n1);
\  fputs(" n2=", vm_out); printarg_n (n2);
\  fputc('\n', vm_out);
\  }
\  #endif
\  {
\  #line 516 "./prim"
\  n = n1+n2;
\  }
\  _x_sp0 = (Cell)n;
\  }
\  NEXT_P1;
\  spTOS = (Cell)_x_sp0;
\  NEXT_P2;

1364
: init-combined ( -- )
1365
    ['] clear-prim-stacks-sync map-stacks
anton's avatar
anton committed
1366
    prim to combined
1367 1368
    0 num-combined !
    current-depth max-stacks cells erase
1369
    include-skipped-insts @ current-depth 0 th !
1370 1371 1372 1373
    max-depth     max-stacks cells erase
    min-depth     max-stacks cells erase
    prim prim-effect-in  prim prim-effect-in-end  !
    prim prim-effect-out prim prim-effect-out-end ! ;
1374 1375 1376 1377

: max! ( n addr -- )
    tuck @ max swap ! ;

1378 1379 1380
: min! ( n addr -- )
    tuck @ min swap ! ;

1381 1382 1383
: inst-stream-adjustment ( nstack -- n )
    \ number of stack items to add for each part
    0= include-skipped-insts @ and negate ;
1384

1385 1386 1387
: add-depths { p -- }
    \ combine stack effect of p with *-depths
    max-stacks 0 ?do
1388
	current-depth i th @
1389
	p prim-stacks-in  i th @ + i inst-stream-adjustment +
1390 1391 1392 1393
	dup max-depth i th max!
	p prim-stacks-out i th @ -
	dup min-depth i th min!
	current-depth i th !
1394 1395
    loop ;

1396 1397 1398
: copy-maxdepths ( n -- )
    max-depth max-depths rot max-stacks * th max-stacks cells move ;

1399 1400 1401 1402
: add-prim ( addr u -- )
    \ add primitive given by "addr u" to combined-prims
    primitives search-wordlist s" unknown primitive" ?print-error
    execute { p }
1403
    p combined-prims num-combined @ th !
1404
    num-combined @ copy-maxdepths
1405
    1 num-combined +!
1406 1407
    p add-depths
    num-combined @ copy-maxdepths ;
1408 1409 1410 1411

: compute-effects { q -- }
    \ compute the stack effects of q from the depths
    max-stacks 0 ?do
1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423
	max-depth i th @ dup
	q prim-stacks-in i th !
	current-depth i th @ -
	q prim-stacks-out i th !
    loop ;

: make-effect-items { stack# items effect-endp -- }
    \ effect-endp points to a pointer to the end of the current item-array
    \ and has to be updated
    stacks stack# th @ { stack }
    items 0 +do
	effect-endp @ { item }
1424
	i 0 <# #s stack stack-pointer 2@ holds '_' hold #> save-mem
1425 1426
	item item-name 2!
	stack item item-stack !
1427
	stack stack-type @ item item-type !
1428 1429 1430 1431 1432 1433 1434 1435 1436 1437
	i item item-offset !
	item item-first on
	item% %size effect-endp +!
    loop ;

: init-effects { q -- }
    \ initialize effects field for FETCHES and STORES
    max-stacks 0 ?do
	i q prim-stacks-in  i th @ q prim-effect-in-end  make-effect-items
	i q prim-stacks-out i th @ q prim-effect-out-end make-effect-items
1438 1439
    loop ;

1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460
: compute-stack-max-back-depths ( stack -- )
    stack-number @ { stack# }
    current-depth stack# th @ dup
    dup stack# num-combined @ s-c-max-back-depth !
    -1 num-combined @ 1- -do ( max-depth current-depth )
	combined-prims i th @ { p }
	p prim-stacks-out stack# th @ +
	dup >r max r>
	over stack# i s-c-max-back-depth !
	p prim-stacks-in stack# th @ -
	stack# inst-stream-adjustment -
    1 -loop
    assert( dup stack# inst-stream-adjustment negate = )
    assert( over max-depth stack# th @ = )
    2drop ;

: compute-max-back-depths ( -- )
    \ compute max-back-depths.
    \ assumes that current-depths is correct for the end of the combination
    ['] compute-stack-max-back-depths map-stacks ;

1461
: process-combined ( -- )
1462
    combined combined-prims num-combined @ cells
anton's avatar
anton committed
1463
    combinations ['] constant insert-wordlist
1464 1465
    combined-prims num-combined @ 1- th ( last-part )
    @ prim-c-code 2@ prim prim-c-code 2! \ used by output-super-end
1466 1467
    prim compute-effects
    prim init-effects
1468
    compute-max-back-depths
1469 1470
    output-combined perform ;

1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490
\ reprocessing (typically to generate versions for another cache states)
\ !! use prim-context

variable reprocessed-num 0 reprocessed-num !

: new-name ( -- c-addr u )
    reprocessed-num @ 0
    1 reprocessed-num +!
    <# #s 'p hold '