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

3
\ Authors: Anton Ertl, Bernd Paysan, Jens Wilke
Anton Ertl's avatar
Anton Ertl committed
4
\ 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
5 6 7 8 9

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


22 23
\ 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
24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39

\ 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:
40
\ add the store optimization for doubles
anton's avatar
anton committed
41 42
\ regarding problem 1 above: It would be better (for over) to implement
\ 	the alternative
43 44 45 46 47 48 49 50 51 52
\ 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
53

54

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

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

64 65
warnings off

66 67 68 69
[IFUNDEF] try
include startup.fs
[THEN]

70 71
: struct% struct ; \ struct is redefined in gray

72
warnings off
73
\ warnings on
74

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

83 84 85
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
86
variable line \ line number of char pointed to by input
87 88
variable line-start \ pointer to start of current line (for error messages)
0 line !
anton's avatar
anton committed
89 90
2variable filename \ filename of original input file
0 0 filename 2!
91 92
2variable out-filename \ filename of the output file (for sync lines)
0 0 out-filename 2!
93 94
2variable f-comment
0 0 f-comment 2!
anton's avatar
anton committed
95
variable skipsynclines \ are sync lines ("#line ...") invisible to the parser?
96 97 98
skipsynclines on
variable out-nls \ newlines in output (for output sync lines)
0 out-nls !
99 100 101
variable store-optimization \ use store optimization?
store-optimization off

102 103 104 105 106
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
107

108 109 110
2variable threaded-code-pointer-type \ type used for geninst etc.
s" Inst **" threaded-code-pointer-type 2!

111 112 113
variable immarg \ values for immediate arguments (to be used in IMM_ARG macros)
$12340000 immarg !

114 115 116 117 118 119 120 121 122
: th ( addr1 n -- addr2 )
    cells + ;

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

anton's avatar
anton committed
124
: insert-wordlist { c-addr u wordlist xt -- }
125 126 127 128 129 130
    \ 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
131
: start ( -- addr )
132
 cookedinput @ ;
anton's avatar
anton committed
133 134

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

137 138 139 140 141 142
: 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 ;

143 144 145 146
: print-error { addr u -- }
    filename 2@ type ." :" line @ 0 .r ." : " addr u type cr
    print-error-line ;

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

153
: quote ( -- )
154
    '"' emit ;
155

156 157 158 159 160 161 162 163 164 165 166 167
\ 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

168 169
variable output          \ xt ( -- ) of output word for simple primitives
variable output-combined \ xt ( -- ) of output word for combined primitives
anton's avatar
anton committed
170

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

179 180 181 182 183
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
184
 cell%	  field item-first  \ true if this is the first occurence of the item
185 186 187 188 189 190 191 192 193 194
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%

195 196 197 198 199 200 201 202 203 204 205 206 207
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%
208
    cell%              field state-enabled
209 210 211 212
    cell%              field state-number
    cell% max-stacks * field state-sss
end-struct state%

213 214
variable next-stack-number 0 next-stack-number !
create stacks max-stacks cells allot \ array of stacks
215 216 217 218
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
219

220 221 222 223 224 225
: 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- ;

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

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

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

250
\ stack items
anton's avatar
anton committed
251

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

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

264 265 266 267 268
\ types

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

269
\ various variables for storing stuff of one primitive
anton's avatar
anton committed
270

271 272 273 274
struct%
    cell% 2* field prim-name
    cell% 2* field prim-wordset
    cell% 2* field prim-c-name
275
    cell% 2* field prim-c-name-orig \ for reprocessed prims, the original name
276 277 278 279
    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
280
    cell%    field prim-num            \ ordinal number
281
    cell%    field prim-items-wordlist \ unique items
282 283 284 285
    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
286 287
    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
288
    cell% max-stacks * field prim-stacks-sync \ sync flag per stack
289 290
end-struct prim%

anton's avatar
anton committed
291 292 293 294 295
: 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
296 297 298 299
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
300 301 302
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
303

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

312 313 314
: prim-c-name-2! ( c-addr u -- )
    2dup prim prim-c-name 2! prim prim-c-name-orig 2! ;

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

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

326 327 328
table constant combinations
  \ the keys are the sequences of pointers to primitives

anton's avatar
anton committed
329 330 331
create current-depth max-stacks cells allot
create max-depth     max-stacks cells allot
create min-depth     max-stacks cells allot
332

333 334 335
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
336 337 338
\ 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
339 340 341 342

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

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

346 347 348
wordlist constant primitives

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

: 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 + ;

359 360 361
: stack-prim-stacks-sync ( stack -- addr )
    prim prim-stacks-sync swap stack-number @ th ;

362
\ global vars
anton's avatar
anton committed
363 364 365 366 367
variable c-line
2variable c-filename
variable name-line
2variable name-filename
2variable last-name-filename
pazsan's avatar
pazsan committed
368
Variable function-number 0 function-number !
pazsan's avatar
pazsan committed
369
Variable function-old 0 function-old !
370
: function-diff ( -- )
pazsan's avatar
pazsan committed
371 372 373 374 375
    ." 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
376 377 378 379 380 381 382 383 384

\ a few more set ops

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

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

385 386 387
\ forward declaration for inst-stream (breaks cycle in definitions)
defer inst-stream-f ( -- stack )

388
\ stack access stuff
anton's avatar
anton committed
389

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

: 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 @
401
    else
402
	drop 0
403
    endif ;
anton's avatar
anton committed
404

405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420
: .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
421 422 423 424 425
	." IMM_ARG(" normal-stack-access1 ." ," immarg ? ." )"
	1 immarg +!
    else
	normal-stack-access1
    endif ;
426

427 428 429
: stack-depth { stack -- n }
    current-depth stack stack-number @ th @ ;

anton's avatar
anton committed
430
: part-stack-access { n stack -- }
431
    \ print _<stack><x>, x=inst-stream? n : maxdepth-currentdepth-n-1
anton's avatar
anton committed
432 433
    ." _" stack stack-pointer 2@ type
    stack stack-number @ { stack# }
434
    stack stack-depth n + { access-depth }
435 436 437 438 439 440 441
    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
442 443
    0 .r ;

444 445 446 447 448
: 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
449
	stack state-in normal-stack-access
450 451 452 453
    else
	drop n stack part-stack-access
    endif ;

454 455 456 457 458 459 460 461 462
: 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 -
463
	stack state-out normal-stack-access
464 465 466
    else
	drop n stack part-stack-access
    endif ;
467 468 469 470 471 472

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

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

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

489 490 491
: item-stack-type-name ( item -- addr u )
    item-stack @ stack-type @ type-c-name 2@ ;

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

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

514
: same-as-in? ( item -- f )
515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532
    \ 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
533

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

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

547 548 549
: store-single { item -- }
    item item-stack @ { stack }
    store-optimization @ in-part @ 0= and item same-as-in? and
550 551
    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
552 553 554
    0= if
	item really-store-single cr
    endif ;
anton's avatar
anton committed
555 556 557 558

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

568 569
: single ( -- xt1 xt2 n )
    ['] fetch-single ['] store-single 1 ;
anton's avatar
anton committed
570

571 572
: double ( -- xt1 xt2 n )
    ['] fetch-double ['] store-double 2 ;
anton's avatar
anton committed
573 574 575 576 577

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

578 579 580 581 582 583 584 585 586 587 588 589 590 591
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" -- )
592 593 594 595 596 597 598 599 600 601
    \ 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
602

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

620 621 622 623 624 625 626 627 628 629
: 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
630 631
	\ we did not find a type, abort
	abort
632
    false s" unknown prefix" ?print-error ;
anton's avatar
anton committed
633 634

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

anton's avatar
anton committed
637 638 639 640
: declaration-list ( addr1 addr2 -- )
    ['] declaration map-items ;

: declarations ( -- )
641
 wordlist dup prim prim-items-wordlist ! set-current
642 643
 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
644

645 646
Variable maybe-unused

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

: print-declarations ( -- )
655
    maybe-unused on
656
    prim prim-effect-in  prim prim-effect-in-end  @ ['] print-declaration map-items
657
    maybe-unused off
658
    prim prim-effect-out prim prim-effect-out-end @ ['] print-declaration map-items ;
659
    
660
: stack-prefix ( stack "prefix" -- )
661
    get-current >r prefixes set-current
662
    name tuck nextname create ( stack length ) 2,
663
    r> set-current
664 665 666 667 668
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
669

670 671 672 673 674 675 676
: set-prim-stacks-sync ( stack -- )
    stack-prim-stacks-sync on ;

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


677 678 679 680 681
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
682
	set-prim-stacks-sync
683
    else \ prefixless "..." syncs all stacks
684
	drop ['] set-prim-stacks-sync map-stacks1
685 686 687 688
    endif ;
set-current

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

: 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 ;

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

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

710 711 712 713 714 715 716
: 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 ;

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

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

730 731 732 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
\ 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 }
764
    s state-enabled on
765 766 767 768 769
    next-state-number @ s state-number ! 1 next-state-number +!
    max-stacks 0 ?do
	default-ss s state-sss i th !
    loop ;

770 771 772 773 774 775
: state-disable ( state -- )
    state-enabled off ;

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

anton's avatar
anton committed
776
: .state ( state -- )
777
    body> >name .name ;
anton's avatar
anton committed
778

779 780 781
: set-ss ( ss stack state -- )
    state-sss swap stack-number @ th ! ;

anton's avatar
anton committed
782 783 784 785
\ offset computation
\ the leftmost (i.e. deepest) item has offset 0
\ the rightmost item has the highest offset

786 787 788 789 790 791
: 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
792 793 794 795 796
: compute-offset-in ( addr1 addr2 -- )
    ['] stack-in compute-offset ;

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

anton's avatar
anton committed
798
: compute-offsets ( -- )
anton's avatar
anton committed
799 800
    prim prim-stacks-in  max-stacks cells erase
    prim prim-stacks-out max-stacks cells erase
801 802
    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
803 804
    inst-stream stack-out @ 0= s" # can only be on the input side" ?print-error ;

805 806
: init-simple { prim -- }
    \ much of the initialization is elsewhere
807
    ['] clear-prim-stacks-sync map-stacks ;
808

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

815 816 817 818 819 820 821 822 823
: 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 ;

824 825 826 827 828 829 830 831
: 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 - ;

832 833 834 835
: 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 )
836
    dup stack spill-stack-items + +do
837 838 839 840 841
	\ 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 ;
842

843 844 845
: spill-state ( -- )
    ['] spill-stack map-stacks1 ;

846 847 848 849 850 851 852 853
: 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
    - ;

854 855 856
: fill-stack { stack -- }
    stack state-out stack-offset { offset }
    stack state-out stack-state-items ( items )
857
    dup stack fill-stack-items + +do
858 859 860 861 862
	\ 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
863

864
: fill-state ( -- )
865
    \ !! inst-stream for prefetching?
866
    ['] fill-stack map-stacks1 ;
867 868

: fetch ( addr -- )
869
    dup item-type @ type-fetch @ execute ;
anton's avatar
anton committed
870 871

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

874 875 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
: 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 ;

907 908 909 910 911 912
: 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 - ;

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

: stack-pointer-update { stack -- }
    \ and moves
    \ stacks grow downwards
926
\    ." /* stack pointer update " stack stack-pointer 2@ type ."  */" cr
927
    stack stack-prim-stacks-sync @ if
928
\	." /* synced "  stack stack-in ? stack stack-out ? stack state-in  stack-offset . ." */" cr
929 930 931 932
	stack stack-in @
	stack state-in  stack-offset -
	stack swap update-stack-pointer
    else
933
\	." /* unsynced "  stack stack-in ? stack stack-out ? ." */" cr
934 935 936 937 938 939
	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 ;
940

anton's avatar
anton committed
941
: stack-pointer-updates ( -- )
942
    ['] stack-pointer-update map-stacks ;
anton's avatar
anton committed
943

944
: stack-pointer-update2 { stack -- }
945
\    ." /* stack pointer update2 " stack stack-pointer 2@ type ."  */" cr
946 947 948 949 950 951 952 953 954 955
    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
956 957 958
: store ( item -- )
\ f is true if the item should be stored
\ f is false if the store is probably not necessary
959
 dup item-type @ type-store @ execute ;
anton's avatar
anton committed
960 961

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

964 965 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
: 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 ;

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

998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008

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

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

1009 1010 1011 1012 1013 1014
: output-nextp2 ( -- )
    ." NEXT_P2;" cr ;

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

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

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

1033 1034 1035 1036 1037 1038 1039 1040 1041 1042
: 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 ;

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

: output-c-tail ( -- )
1051
    tail-nextp2 @ output-c-tail1 ;
1052

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

: output-c-tail-no-stores ( -- )
1061
    tail-nextp2 @ output-c-tail1-no-stores ;
1062 1063

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

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

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

: 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 ;

1093
: output-c ( -- )
pazsan's avatar
pazsan committed
1094
    print-entry ."  /* " prim prim-name 2@ prim-type
anton's avatar
anton committed
1095 1096
    ."  ( " prim prim-stack-string 2@ type ." ) "
    state-in .state ." -- " state-out .state ."  */" cr
1097 1098 1099 1100 1101
    ." /* " prim prim-doc 2@ type ."  */" cr
    ." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging
    ." {" cr
    ." DEF_CA" cr
    print-declarations
1102
    output-nextp0
1103
    spill-state
1104 1105 1106 1107 1108 1109 1110
    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
1111 1112
;

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

: disasm-args ( -- )
1123
    prim prim-effect-in prim prim-effect-in-end @ ['] disasm-arg map-items ;
1124 1125 1126

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

1134 1135
: output-profile ( -- )
    \ generate code for postprocessing the VM block profile stuff
anton's avatar
anton committed
1136
    ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr
1137
    ."   add_inst(b, " quote prim prim-name 2@ type quote ." );" cr
1138 1139 1140 1141
    ."   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
1142 1143
    else
	."   goto _endif_;" cr
1144
    endif
1145
    ." }" cr ;
1146

1147 1148 1149 1150 1151
: output-profile-part ( p )
    ."   add_inst(b, " quote
    prim-name 2@ type
    quote ." );" cr ;
    
1152 1153 1154
: output-profile-combined ( -- )
    \ generate code for postprocessing the VM block profile stuff
    ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr
1155
    ['] output-profile-part map-combined
1156 1157 1158 1159 1160 1161 1162 1163 1164
    ."   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 ;

1165 1166 1167 1168
: 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<> ;

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

1176 1177 1178 1179 1180 1181 1182
: 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 ( -- )
1183
    prim prim-effect-in prim prim-effect-in-end @ ['] gen-arg-parm map-items ;
1184 1185 1186 1187 1188 1189 1190 1191

: 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 ( -- )
1192
    prim prim-effect-in prim prim-effect-in-end @ ['] gen-arg-gen map-items ;
1193 1194 1195

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

1203 1204
: stack-used? { stack -- f }
    stack stack-in @ stack stack-out @ or 0<> ;
1205

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

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

1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225
\  : 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
1226
\      spill-state
1227 1228 1229 1230 1231 1232 1233 1234
\      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
1235
\      fill-state
1236 1237 1238
\      ." return (sp);" cr
\      ." }" cr
\      cr ;
pazsan's avatar
pazsan committed
1239

1240
: output-label ( -- )  
1241
    ." INST_ADDR(" prim prim-c-name 2@ type ." )," cr ;
anton's avatar
anton committed
1242

Anton Ertl's avatar
Anton Ertl committed
1243 1244 1245 1246
: 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
1247

1248 1249 1250
defer output-c-prim-num ( -- )

:noname ( -- )
1251
    ." N_" prim prim-c-name 2@ type ." ," cr ;
1252
is output-c-prim-num
1253

1254
: output-forth ( -- )  
1255
    prim prim-forth-code @ 0=
pazsan's avatar
pazsan committed
1256
    IF    	\ output-alias
jwilke's avatar
jwilke committed
1257 1258
	\ this is bad for ec: an alias is compiled if tho word does not exist!
	\ JAW
1259 1260 1261
    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
1262
    THEN ;
1263

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

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

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

1286 1287
[IFDEF] documentation
: register-doc ( -- )
anton's avatar
anton committed
1288
    prim prim-name 2@ documentation ['] create insert-wordlist
1289 1290 1291 1292
    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
1293
    prim prim-doc 2@ 2, ;
1294
[THEN]
1295

anton's avatar
anton committed
1296

1297 1298 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
\ 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;

1361
: init-combined ( -- )
1362
    ['] clear-prim-stacks-sync map-stacks
anton's avatar
anton committed
1363
    prim to combined
1364 1365
    0 num-combined !
    current-depth max-stacks cells erase
1366
    include-skipped-insts @ current-depth 0 th !
1367 1368 1369 1370
    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 ! ;
1371 1372 1373 1374

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

1375 1376 1377
: min! ( n addr -- )
    tuck @ min swap ! ;

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

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

1393 1394 1395
: copy-maxdepths ( n -- )
    max-depth max-depths rot max-stacks * th max-stacks cells move ;

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

: compute-effects { q -- }
    \ compute the stack effects of q from the depths
    max-stacks 0 ?do
1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420
	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 }
1421
	i 0 <# #s stack stack-pointer 2@ holds '_' hold #> save-mem
1422 1423
	item item-name 2!
	stack item item-stack !
1424
	stack stack-type @ item item-type !
1425 1426 1427 1428 1429 1430 1431 1432 1433 1434
	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
1435 1436
    loop ;

1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457
: 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 ;

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

1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487
\ 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 +!