1\ converts primitives to, e.g., C code 2 3\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2009,2010,2011 Free Software Foundation, Inc. 4 5\ This file is part of Gforth. 6 7\ Gforth is free software; you can redistribute it and/or 8\ modify it under the terms of the GNU General Public License 9\ as published by the Free Software Foundation, either version 3 10\ of the License, or (at your option) any later version. 11 12\ This program is distributed in the hope that it will be useful, 13\ but WITHOUT ANY WARRANTY; without even the implied warranty of 14\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15\ GNU General Public License for more details. 16 17\ 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/. 19 20 21\ This is not very nice (hard limits, no checking, assumes 1 chars = 1). 22\ And it grew even worse when it aged. 23 24\ Optimizations: 25\ superfluous stores are removed. GCC removes the superfluous loads by itself 26\ TOS and FTOS can be kept in register( variable)s. 27\ 28\ Problems: 29\ The TOS optimization is somewhat hairy. The problems by example: 30\ 1) dup ( w -- w w ): w=TOS; sp-=1; sp[1]=w; TOS=w; 31\ The store is not superfluous although the earlier opt. would think so 32\ Alternatively: sp[0]=TOS; w=TOS; sp-=1; TOS=w; 33\ 2) ( -- .. ): sp[0] = TOS; ... /* This additional store is necessary */ 34\ 3) ( .. -- ): ... TOS = sp[0]; /* as well as this load */ 35\ 4) ( -- ): /* but here they are unnecessary */ 36\ 5) Words that call NEXT themselves have to be done very carefully. 37\ 38\ To do: 39\ add the store optimization for doubles 40\ regarding problem 1 above: It would be better (for over) to implement 41\ the alternative 42\ store optimization for combined instructions. 43 44\ Design Uglyness: 45 46\ - global state (values, variables) in connection with combined instructions. 47 48\ - index computation is different for instruction-stream and the 49\ stacks; there are two mechanisms for dealing with that 50\ (stack-in-index-xt and a test for stack==instruction-stream); there 51\ should be only one. 52 53 54\ for backwards compatibility, jaw 55require compat/strcomp.fs 56 57[undefined] outfile-execute [if] 58 : outfile-execute ( ... xt file-id -- ... ) 59 \ unsafe replacement 60 outfile-id >r to outfile-id execute r> to outfile-id ; 61[then] 62 63warnings off 64 65\ redefinitions of kernel words not present in gforth-0.6.1 66: latestxt lastcfa @ ; 67: latest last @ ; 68 69[IFUNDEF] try 70include startup.fs 71[THEN] 72 73: struct% struct ; \ struct is redefined in gray 74 75warnings off 76\ warnings on 77 78include ./gray.fs 79128 constant max-effect \ number of things on one side of a stack effect 804 constant max-stacks \ the max. number of stacks (including inst-stream). 81255 constant maxchar 82maxchar 1+ constant eof-char 83#tab constant tab-char 84#lf constant nl-char 85 86variable rawinput \ pointer to next character to be scanned 87variable endrawinput \ pointer to the end of the input (the char after the last) 88variable cookedinput \ pointer to the next char to be parsed 89variable line \ line number of char pointed to by input 90variable line-start \ pointer to start of current line (for error messages) 910 line ! 922variable filename \ filename of original input file 930 0 filename 2! 942variable out-filename \ filename of the output file (for sync lines) 950 0 out-filename 2! 962variable f-comment 970 0 f-comment 2! 98variable skipsynclines \ are sync lines ("#line ...") invisible to the parser? 99skipsynclines on 100variable out-nls \ newlines in output (for output sync lines) 1010 out-nls ! 102variable store-optimization \ use store optimization? 103store-optimization off 104 105variable include-skipped-insts 106\ does the threaded code for a combined instruction include the cells 107\ for the component instructions (true) or only the cells for the 108\ inline arguments (false) 109include-skipped-insts off 110 1112variable threaded-code-pointer-type \ type used for geninst etc. 112s" Inst **" threaded-code-pointer-type 2! 113 114variable immarg \ values for immediate arguments (to be used in IMM_ARG macros) 115$12340000 immarg ! 116 117: th ( addr1 n -- addr2 ) 118 cells + ; 119 120: holds ( addr u -- ) 121 \ like HOLD, but for a string 122 tuck + swap 0 +do 123 1- dup c@ hold 124 loop 125 drop ; 126 127: insert-wordlist { c-addr u wordlist xt -- } 128 \ adds name "addr u" to wordlist using defining word xt 129 \ xt may cause additional stack effects 130 get-current >r wordlist set-current 131 c-addr u nextname xt execute 132 r> set-current ; 133 134: start ( -- addr ) 135 cookedinput @ ; 136 137: end ( addr -- addr u ) 138 cookedinput @ over - ; 139 140: print-error-line ( -- ) 141 \ print the current line and position 142 line-start @ endrawinput @ over - 2dup nl-char scan drop nip ( start end ) 143 over - type cr 144 line-start @ rawinput @ over - typewhite ." ^" cr ; 145 146: print-error { addr u -- } 147 filename 2@ type ." :" line @ 0 .r ." : " addr u type cr 148 print-error-line ; 149 150: ?print-error { f addr u -- } 151 f ?not? if 152 addr u ['] print-error stderr outfile-execute 153 1 (bye) \ abort 154 endif ; 155 156: quote ( -- ) 157 [char] " emit ; 158 159\ count output lines to generate sync lines for output 160 161: count-nls ( addr u -- ) 162 bounds u+do 163 i c@ nl-char = negate out-nls +! 164 loop ; 165 166:noname ( addr u -- ) 167 2dup count-nls 168 defers type ; 169is type 170 171variable output \ xt ( -- ) of output word for simple primitives 172variable output-combined \ xt ( -- ) of output word for combined primitives 173 174struct% 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 ) 180end-struct stack% 181 182struct% 183 cell% 2* field item-name \ name, excluding stack prefixes 184 cell% field item-stack \ descriptor for the stack used, 0 is default 185 cell% field item-type \ descriptor for the item type 186 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 188end-struct item% 189 190struct% 191 cell% 2* field type-c-name 192 cell% field type-stack \ default stack 193 cell% field type-size \ size of type in stack items 194 cell% field type-fetch \ xt of fetch code generator ( item -- ) 195 cell% field type-store \ xt of store code generator ( item -- ) 196end-struct type% 197 198struct% 199 cell% field register-number 200 cell% field register-type \ pointer to type 201 cell% 2* field register-name \ c name 202end-struct register% 203 204struct% 205 cell% 2* field ss-registers \ addr u; ss-registers[0] is TOS 206 \ 0 means: use memory 207 cell% field ss-offset \ stack pointer offset: sp[-offset] is TOS 208end-struct ss% \ stack-state 209 210struct% 211 cell% field state-enabled 212 cell% field state-number 213 cell% max-stacks * field state-sss 214end-struct state% 215 216variable next-stack-number 0 next-stack-number ! 217create stacks max-stacks cells allot \ array of stacks 218256 constant max-registers 219create registers max-registers cells allot \ array of registers 220variable nregisters 0 nregisters ! \ number of registers 221variable next-state-number 0 next-state-number ! \ next state number 222 223: stack-in-index ( in-size item -- in-index ) 224 item-offset @ - 1- ; 225 226: inst-in-index ( in-size item -- in-index ) 227 nip dup item-offset @ swap item-type @ type-size @ + 1- ; 228 229: make-stack ( addr-ptr u1 type "stack-name" -- ) 230 next-stack-number @ max-stacks < s" too many stacks" ?print-error 231 create stack% %allot >r 232 r@ stacks next-stack-number @ th ! 233 next-stack-number @ r@ stack-number ! 234 1 next-stack-number +! 235 r@ stack-type ! 236 save-mem r@ stack-pointer 2! 237 ['] stack-in-index r@ stack-in-index-xt ! 238 ['] noop r@ stack-access-transform ! 239 rdrop ; 240 241: map-stacks { xt -- } 242 \ perform xt ( stack -- ) for all stacks 243 next-stack-number @ 0 +do 244 stacks i th @ xt execute 245 loop ; 246 247: map-stacks1 { xt -- } 248 \ perform xt ( stack -- ) for all stacks except inst-stream 249 next-stack-number @ 1 +do 250 stacks i th @ xt execute 251 loop ; 252 253\ stack items 254 255: init-item ( addr u addr1 -- ) 256 \ initialize item at addr1 with name addr u 257 \ the stack prefix is removed by the stack-prefix 258 dup item% %size erase 259 item-name 2! ; 260 261: map-items { addr end xt -- } 262 \ perform xt for all items in array addr...end 263 end addr ?do 264 i xt execute 265 item% %size +loop ; 266 267\ types 268 269: print-type-prefix ( type -- ) 270 body> >head name>string type ; 271 272\ various variables for storing stuff of one primitive 273 274struct% 275 cell% 2* field prim-name 276 cell% 2* field prim-wordset 277 cell% 2* field prim-c-name 278 cell% 2* field prim-c-name-orig \ for reprocessed prims, the original name 279 cell% 2* field prim-doc 280 cell% 2* field prim-c-code 281 cell% 2* field prim-forth-code 282 cell% 2* field prim-stack-string 283 cell% field prim-num \ ordinal number 284 cell% field prim-items-wordlist \ unique items 285 item% max-effect * field prim-effect-in 286 item% max-effect * field prim-effect-out 287 cell% field prim-effect-in-end 288 cell% field prim-effect-out-end 289 cell% max-stacks * field prim-stacks-in \ number of in items per stack 290 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 292end-struct prim% 293 294: make-prim ( -- prim ) 295 prim% %alloc { p } 296 s" " p prim-doc 2! s" " p prim-forth-code 2! s" " p prim-wordset 2! 297 p ; 298 2990 value prim \ in combined prims either combined or a part 3000 value combined \ in combined prims the combined prim 301variable in-part \ true if processing a part 302 in-part off 3030 value state-in \ state on entering prim 3040 value state-out \ state on exiting prim 3050 value state-default \ canonical state at bb boundaries 306 307: prim-context ( ... p xt -- ... ) 308 \ execute xt with prim set to p 309 prim >r 310 swap to prim 311 catch 312 r> to prim 313 throw ; 314 315: prim-c-name-2! ( c-addr u -- ) 316 2dup prim prim-c-name 2! prim prim-c-name-orig 2! ; 317 3181000 constant max-combined 319create combined-prims max-combined cells allot 320variable num-combined 321variable part-num \ current part number during process-combined 322 323: map-combined { xt -- } 324 \ perform xt for all components of the current combined instruction 325 num-combined @ 0 +do 326 combined-prims i th @ xt execute 327 loop ; 328 329table constant combinations 330 \ the keys are the sequences of pointers to primitives 331 332create current-depth max-stacks cells allot 333create max-depth max-stacks cells allot 334create min-depth max-stacks cells allot 335 336create sp-update-in max-stacks cells allot 337\ where max-depth occured the first time 338create max-depths max-stacks max-combined 1+ * cells allot 339\ maximum depth at start of each part: array[parts] of array[stack] 340create max-back-depths max-stacks max-combined 1+ * cells allot 341\ maximun depth from end of the combination to the start of the each part 342 343: s-c-max-depth ( nstack ncomponent -- addr ) 344 max-stacks * + cells max-depths + ; 345 346: s-c-max-back-depth ( nstack ncomponent -- addr ) 347 max-stacks * + cells max-back-depths + ; 348 349wordlist constant primitives 350 351: create-prim ( prim -- ) 352 dup prim-name 2@ primitives ['] constant insert-wordlist ; 353 354: stack-in ( stack -- addr ) 355 \ address of number of stack items in effect in 356 stack-number @ cells prim prim-stacks-in + ; 357 358: stack-out ( stack -- addr ) 359 \ address of number of stack items in effect out 360 stack-number @ cells prim prim-stacks-out + ; 361 362: stack-prim-stacks-sync ( stack -- addr ) 363 prim prim-stacks-sync swap stack-number @ th ; 364 365\ global vars 366variable c-line 3672variable c-filename 368variable name-line 3692variable name-filename 3702variable last-name-filename 371Variable function-number 0 function-number ! 372Variable function-old 0 function-old ! 373: function-diff ( -- ) 374 ." GROUPADD(" function-number @ function-old @ - 0 .r ." )" cr 375 function-number @ function-old ! ; 376: forth-fdiff ( -- ) 377 function-number @ function-old @ - 0 .r ." groupadd" cr 378 function-number @ function-old ! ; 379 380\ a few more set ops 381 382: bit-equivalent ( w1 w2 -- w3 ) 383 xor invert ; 384 385: complement ( set1 -- set2 ) 386 empty ['] bit-equivalent binary-set-operation ; 387 388\ forward declaration for inst-stream (breaks cycle in definitions) 389defer inst-stream-f ( -- stack ) 390 391\ stack access stuff 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: state-ss { stack state -- ss } 398 state state-sss stack stack-number @ th @ ; 399 400: stack-reg { n stack state -- reg } 401 \ n is the index (TOS=0); reg is 0 if the access is to memory 402 stack state state-ss ss-registers 2@ n u> if ( addr ) \ in ss-registers? 403 n th @ 404 else 405 drop 0 406 endif ; 407 408: .reg ( reg -- ) 409 register-name 2@ type ; 410 411: stack-offset ( stack state -- n ) 412 \ offset for stack in state 413 state-ss ss-offset @ ; 414 415: normal-stack-access1 { n stack state -- } 416 n stack state stack-reg ?dup-if 417 .reg exit 418 endif 419 stack stack-pointer 2@ type 420 n stack state stack-offset - stack normal-stack-access0 ; 421 422: normal-stack-access ( n stack state -- ) 423 over inst-stream-f = if 424 ." IMM_ARG(" normal-stack-access1 ." ," immarg ? ." )" 425 1 immarg +! 426 else 427 normal-stack-access1 428 endif ; 429 430: stack-depth { stack -- n } 431 current-depth stack stack-number @ th @ ; 432 433: part-stack-access { n stack -- } 434 \ print _<stack><x>, x=inst-stream? n : maxdepth-currentdepth-n-1 435 ." _" stack stack-pointer 2@ type 436 stack stack-number @ { stack# } 437 stack stack-depth n + { access-depth } 438 stack inst-stream-f = if 439 access-depth 440 else 441 combined prim-stacks-in stack# th @ 442 assert( dup max-depth stack# th @ = ) 443 access-depth - 1- 444 endif 445 0 .r ; 446 447: part-stack-read { n stack -- } 448 stack stack-depth n + ( ndepth ) 449 stack stack-number @ part-num @ s-c-max-depth @ 450\ max-depth stack stack-number @ th @ ( ndepth nmaxdepth ) 451 over <= if ( ndepth ) \ load from memory 452 stack state-in normal-stack-access 453 else 454 drop n stack part-stack-access 455 endif ; 456 457: stack-diff ( stack -- n ) 458 \ in-out 459 dup stack-in @ swap stack-out @ - ; 460 461: part-stack-write { n stack -- } 462 stack stack-depth n + 463 stack stack-number @ part-num @ s-c-max-back-depth @ 464 over <= if ( ndepth ) 465 stack combined ['] stack-diff prim-context - 466 stack state-out normal-stack-access 467 else 468 drop n stack part-stack-access 469 endif ; 470 471: stack-read ( n stack -- ) 472 \ print a stack access at index n of stack 473 in-part @ if 474 part-stack-read 475 else 476 state-in normal-stack-access 477 endif ; 478 479: stack-write ( n stack -- ) 480 \ print a stack access at index n of stack 481 in-part @ if 482 part-stack-write 483 else 484 state-out normal-stack-access 485 endif ; 486 487: item-in-index { item -- n } 488 \ n is the index of item (in the in-effect) 489 item item-stack @ dup >r stack-in @ ( in-size r:stack ) 490 item r> stack-in-index-xt @ execute ; 491 492: item-stack-type-name ( item -- addr u ) 493 item-stack @ stack-type @ type-c-name 2@ ; 494 495: fetch-single ( item -- ) 496 \ fetch a single stack item from its stack 497 >r 498 ." vm_" r@ item-stack-type-name type 499 ." 2" r@ item-type @ print-type-prefix ." (" 500 r@ item-in-index r@ item-stack @ stack-read ." ," 501 r@ item-name 2@ type 502 ." );" cr 503 rdrop ; 504 505: fetch-double ( item -- ) 506 \ fetch a double stack item from its stack 507 >r 508 ." vm_two" 509 r@ item-stack-type-name type ." 2" 510 r@ item-type @ print-type-prefix ." (" 511 r@ item-in-index r@ item-stack @ 2dup stack-read 512 ." , " -1 under+ stack-read 513 ." , " r@ item-name 2@ type 514 ." )" cr 515 rdrop ; 516 517: same-as-in? ( item -- f ) 518 \ f is true iff the offset and stack of item is the same as on input 519 >r 520 r@ item-stack @ stack-prim-stacks-sync @ if 521 rdrop false exit 522 endif 523 r@ item-first @ if 524 rdrop false exit 525 endif 526 r@ item-name 2@ prim prim-items-wordlist @ search-wordlist 0= abort" bug" 527 execute @ 528 dup r@ = 529 if \ item first appeared in output 530 drop false 531 else 532 dup item-stack @ r@ item-stack @ = 533 swap item-offset @ r@ item-offset @ = and 534 endif 535 rdrop ; 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- ; 540 541: really-store-single ( item -- ) 542 >r 543 ." vm_" 544 r@ item-type @ print-type-prefix ." 2" 545 r@ item-stack-type-name type ." (" 546 r@ item-name 2@ type ." ," 547 r@ item-out-index r@ item-stack @ stack-write ." );" 548 rdrop ; 549 550: store-single { item -- } 551 item item-stack @ { stack } 552 store-optimization @ in-part @ 0= and item same-as-in? and 553 item item-in-index stack state-in stack-reg \ in reg/mem 554 item item-out-index stack state-out stack-reg = and \ out reg/mem 555 0= if 556 item really-store-single cr 557 endif ; 558 559: store-double ( item -- ) 560\ !! store optimization is not performed, because it is not yet needed 561 >r 562 ." vm_" 563 r@ item-type @ print-type-prefix ." 2two" 564 r@ item-stack-type-name type ." (" 565 r@ item-name 2@ type ." , " 566 r@ item-out-index r@ item-stack @ 2dup stack-write 567 ." , " -1 under+ stack-write 568 ." )" cr 569 rdrop ; 570 571: single ( -- xt1 xt2 n ) 572 ['] fetch-single ['] store-single 1 ; 573 574: double ( -- xt1 xt2 n ) 575 ['] fetch-double ['] store-double 2 ; 576 577: s, ( addr u -- ) 578\ allocate a string 579 here swap dup allot move ; 580 581wordlist constant prefixes 582 583: declare ( addr "name" -- ) 584\ remember that there is a stack item at addr called name 585 create , ; 586 587: !default ( w addr -- ) 588 dup @ if 589 2drop \ leave nonzero alone 590 else 591 ! 592 endif ; 593 594: create-type { addr u xt1 xt2 n stack -- } ( "prefix" -- ) 595 \ describes a type 596 \ addr u specifies the C type name 597 \ stack effect entries of the type start with prefix 598 create type% %allot >r 599 addr u save-mem r@ type-c-name 2! 600 xt1 r@ type-fetch ! 601 xt2 r@ type-store ! 602 n r@ type-size ! 603 stack r@ type-stack ! 604 rdrop ; 605 606: type-prefix ( addr u xt1 xt2 n stack "prefix" -- ) 607 get-current >r prefixes set-current 608 create-type r> set-current 609does> ( item -- ) 610 \ initialize item 611 { item typ } 612 typ item item-type ! 613 typ type-stack @ item item-stack !default 614 item item-name 2@ prim prim-items-wordlist @ search-wordlist 0= if 615 item item-name 2@ nextname item declare 616 item item-first on 617 \ typ type-c-name 2@ type space type ." ;" cr 618 else 619 drop 620 item item-first off 621 endif ; 622 623: execute-prefix ( item addr1 u1 -- ) 624 \ execute the word ( item -- ) associated with the longest prefix 625 \ of addr1 u1 626 0 swap ?do 627 dup i prefixes search-wordlist 628 if \ ok, we have the type ( item addr1 xt ) 629 nip execute 630 UNLOOP EXIT 631 endif 632 -1 s+loop 633 \ we did not find a type, abort 634 abort 635 false s" unknown prefix" ?print-error ; 636 637: declaration ( item -- ) 638 dup item-name 2@ execute-prefix ; 639 640: declaration-list ( addr1 addr2 -- ) 641 ['] declaration map-items ; 642 643: declarations ( -- ) 644 wordlist dup prim prim-items-wordlist ! set-current 645 prim prim-effect-in prim prim-effect-in-end @ declaration-list 646 prim prim-effect-out prim prim-effect-out-end @ declaration-list ; 647 648Variable maybe-unused 649 650: print-declaration { item -- } 651 item item-first @ if 652 maybe-unused @ IF ." MAYBE_UNUSED " THEN 653 item item-type @ type-c-name 2@ type space 654 item item-name 2@ type ." ;" cr 655 endif ; 656 657: 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 667does> ( item -- ) 668 2@ { item stack prefix-length } 669 item item-name 2@ prefix-length /string item item-name 2! 670 stack item item-stack ! 671 item declaration ; 672 673: set-prim-stacks-sync ( stack -- ) 674 stack-prim-stacks-sync on ; 675 676: clear-prim-stacks-sync ( stack -- ) 677 stack-prim-stacks-sync off ; 678 679 680get-current prefixes set-current 681: ... ( item -- ) 682 \ this "prefix" ensures that the appropriate stack is synced with memory 683 dup item-name 2@ s" ..." str= 0= abort" '...' must end the item name" 684 item-stack @ dup if 685 set-prim-stacks-sync 686 else \ prefixless "..." syncs all stacks 687 drop ['] set-prim-stacks-sync map-stacks1 688 endif ; 689set-current 690 691create ...-item ( -- addr ) \ just used for letting stack-prefixes work on it 692item% %allot drop \ stores the stack temporarily until used by ... 693 694: init-item1 ( addr1 addr u -- addr2 ) 695 \ initialize item at addr1 with name addr u, next item is at addr2 696 \ !! make sure that any mention of "..." is only stack-prefixed 697 2dup s" ..." search nip nip if ( addr1 addr u ) 698 0 ...-item item-stack ! \ initialize to prefixless 699 2dup ...-item item-name 2! 700 ...-item rot rot execute-prefix ( addr1 ) 701 else 702 2 pick init-item item% %size + 703 endif ; 704 705\ types pointed to by stacks for use in combined prims 706\ !! output-c-combined shouldn't use these names! 707: stack-type-name ( addr u "name" -- ) 708 single 0 create-type ; 709 710wordlist constant type-names \ this is here just to meet the requirement 711 \ that a type be a word; it is never used for lookup 712 713: define-type ( addr u -- xt ) 714 \ define single type with name addr u, without stack 715 get-current type-names set-current >r 716 2dup nextname stack-type-name 717 r> set-current 718 latestxt ; 719 720: stack ( "name" "stack-pointer" "type" -- ) 721 \ define stack 722 name { d: stack-name } 723 name { d: stack-pointer } 724 name { d: stack-type } 725 stack-type define-type 726 stack-pointer rot >body stack-name nextname make-stack ; 727 728stack inst-stream IP Cell 729' inst-in-index inst-stream stack-in-index-xt ! 730' inst-stream <is> inst-stream-f 731\ !! initialize stack-in and stack-out 732 733\ registers 734 735: make-register ( type addr u -- ) 736 \ define register with type TYPE and name ADDR U. 737 nregisters @ max-registers < s" too many registers" ?print-error 738 2dup nextname create register% %allot >r 739 r@ register-name 2! 740 r@ register-type ! 741 nregisters @ r@ register-number ! 742 1 nregisters +! 743 rdrop ; 744 745: register ( "name" "type" -- ) 746 \ define register 747 name { d: reg-name } 748 name { d: reg-type } 749 reg-type define-type >body 750 reg-name make-register ; 751 752\ stack-states 753 754: stack-state ( a-addr u uoffset "name" -- ) 755 create ss% %allot >r 756 r@ ss-offset ! 757 r@ ss-registers 2! 758 rdrop ; 759 7600 0 0 stack-state default-ss 761 762\ state 763 764: state ( "name" -- ) 765 \ create a state initialized with default-sss 766 create state% %allot { s } 767 s state-enabled on 768 next-state-number @ s state-number ! 1 next-state-number +! 769 max-stacks 0 ?do 770 default-ss s state-sss i th ! 771 loop ; 772 773: state-disable ( state -- ) 774 state-enabled off ; 775 776: state-enabled? ( state -- f ) 777 state-enabled @ ; 778 779: .state ( state -- ) 780 0 >body - >name .name ; 781 782: set-ss ( ss stack state -- ) 783 state-sss swap stack-number @ th ! ; 784 785\ offset computation 786\ the leftmost (i.e. deepest) item has offset 0 787\ the rightmost item has the highest offset 788 789: compute-offset { item xt -- } 790 \ xt specifies in/out; update stack-in/out and set item-offset 791 item item-type @ type-size @ 792 item item-stack @ xt execute dup @ >r +! 793 r> item item-offset ! ; 794 795: compute-offset-in ( addr1 addr2 -- ) 796 ['] stack-in compute-offset ; 797 798: compute-offset-out ( addr1 addr2 -- ) 799 ['] stack-out compute-offset ; 800 801: compute-offsets ( -- ) 802 prim prim-stacks-in max-stacks cells erase 803 prim prim-stacks-out max-stacks cells erase 804 prim prim-effect-in prim prim-effect-in-end @ ['] compute-offset-in map-items 805 prim prim-effect-out prim prim-effect-out-end @ ['] compute-offset-out map-items 806 inst-stream stack-out @ 0= s" # can only be on the input side" ?print-error ; 807 808: init-simple { prim -- } 809 \ much of the initialization is elsewhere 810 ['] clear-prim-stacks-sync map-stacks ; 811 812: process-simple ( -- ) 813 prim prim { W^ key } key cell 814 combinations ['] constant insert-wordlist 815 declarations compute-offsets 816 output @ execute ; 817 818: stack-state-items ( stack state -- n ) 819 state-ss ss-registers 2@ nip ; 820 821: unused-stack-items { stack -- n-in n-out } 822 \ n-in are the stack items in state-in not used by prim 823 \ n-out are the stack items in state-out not written by prim 824 stack state-in stack-state-items stack stack-in @ - 0 max 825 stack state-out stack-state-items stack stack-out @ - 0 max ; 826 827: spill-stack-items { stack -- u } 828 \ there are u items to spill in stack 829 stack unused-stack-items 830 stack stack-prim-stacks-sync @ if 831 drop 0 832 endif 833 swap - ; 834 835: spill-stack { stack -- } 836 \ spill regs of state-in that are not used by prim and are not in state-out 837 stack state-in stack-offset { offset } 838 stack state-in stack-state-items ( items ) 839 dup stack spill-stack-items + +do 840 \ loop through the bottom items 841 stack stack-pointer 2@ type 842 i offset - stack normal-stack-access0 ." = " 843 i stack state-in normal-stack-access1 ." ;" cr 844 loop ; 845 846: spill-state ( -- ) 847 ['] spill-stack map-stacks1 ; 848 849: fill-stack-items { stack -- u } 850 \ there are u items to fill in stack 851 stack unused-stack-items 852 stack stack-prim-stacks-sync @ if 853 swap drop 0 swap 854 endif 855 - ; 856 857: fill-stack { stack -- } 858 stack state-out stack-offset { offset } 859 stack state-out stack-state-items ( items ) 860 dup stack fill-stack-items + +do 861 \ loop through the bottom items 862 i stack state-out normal-stack-access1 ." = " 863 stack stack-pointer 2@ type 864 i offset - stack normal-stack-access0 ." ;" cr 865 loop ; 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 ; 873 874: fetches ( -- ) 875 prim prim-effect-in prim prim-effect-in-end @ ['] fetch map-items ; 876 877: reg-reg-move ( reg-from reg-to -- ) 878 2dup = if 879 2drop 880 else 881 .reg ." = " .reg ." ;" cr 882 endif ; 883 884: stack-bottom-reg { n stack state -- reg } 885 stack state stack-state-items n - 1- stack state stack-reg ; 886 887: stack-moves { stack -- } 888 \ generate moves between registers in state-in/state-out that are 889 \ not spilled or consumed/produced by prim. 890 \ !! this works only for a simple stack cache, not e.g., for 891 \ rotating stack caches, or registers shared between stacks (the 892 \ latter would also require a change in interface) 893 \ !! maybe place this after NEXT_P1? 894 stack unused-stack-items 2dup < if ( n-in n-out ) 895 \ move registers from 0..n_in-1 to n_out-n_in..n_out-1 896 over - { diff } ( n-in ) 897 -1 swap 1- -do 898 i stack state-in stack-bottom-reg ( reg-from ) 899 i diff + stack state-out stack-bottom-reg reg-reg-move 900 1 -loop 901 else 902 \ move registers from n_in-n_out..n_in-1 to 0..n_out-1 903 swap over - { diff } ( n-out ) 904 0 +do 905 i diff + stack state-in stack-bottom-reg ( reg-from ) 906 i stack state-out stack-bottom-reg reg-reg-move 907 loop 908 endif ; 909 910: stack-update-transform ( n1 stack -- n2 ) 911 \ n2 is the number by which the stack pointer should be 912 \ incremented to pop n1 items 913 stack-access-transform @ dup >r execute 914 0 r> execute - ; 915 916: update-stack-pointer { stack n -- } 917 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 endif ; 925 926: stack-pointer-update { stack -- } 927 \ and moves 928 \ 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 stack stack-in @ 933 stack state-in stack-offset - 934 stack swap update-stack-pointer 935 else 936\ ." /* unsynced " stack stack-in ? stack stack-out ? ." */" cr 937 stack stack-diff ( in-out ) 938 stack state-in stack-offset - 939 stack state-out stack-offset + ( [in-in_offset]-[out-out_offset] ) 940 stack swap update-stack-pointer 941 stack stack-moves 942 endif ; 943 944: stack-pointer-updates ( -- ) 945 ['] stack-pointer-update map-stacks ; 946 947: stack-pointer-update2 { stack -- } 948\ ." /* stack pointer update2 " stack stack-pointer 2@ type ." */" cr 949 stack stack-prim-stacks-sync @ if 950 stack state-out stack-offset 951 stack stack-out @ - 952 stack swap update-stack-pointer 953 endif ; 954 955: stack-pointer-updates2 ( -- ) 956 \ update stack pointers after C code, where necessary 957 ['] stack-pointer-update2 map-stacks ; 958 959: store ( item -- ) 960\ f is true if the item should be stored 961\ f is false if the store is probably not necessary 962 dup item-type @ type-store @ execute ; 963 964: stores ( -- ) 965 prim prim-effect-out prim prim-effect-out-end @ ['] store map-items ; 966 967: print-debug-arg { item -- } 968 ." fputs(" quote space item item-name 2@ type ." =" quote ." , vm_out); " 969 ." printarg_" item item-type @ print-type-prefix 970 ." (" item item-name 2@ type ." );" cr ; 971 972: print-debug-args ( -- ) 973 ." #ifdef VM_DEBUG" cr 974 ." if (vm_debug) {" cr 975 prim prim-effect-in prim prim-effect-in-end @ ['] print-debug-arg map-items 976\ ." fputc('\n', vm_out);" cr 977 ." }" cr 978 ." #endif" cr ; 979 980: print-debug-result { item -- } 981 item item-first @ if 982 item print-debug-arg 983 endif ; 984 985: print-debug-results ( -- ) 986 cr 987 ." #ifdef VM_DEBUG" cr 988 ." if (vm_debug) {" cr 989 ." fputs(" quote ." -- " quote ." , vm_out); " 990 prim prim-effect-out prim prim-effect-out-end @ ['] print-debug-result map-items 991 ." fputc('\n', vm_out);" cr 992 ." }" cr 993 ." #endif" cr ; 994 995: output-super-end ( -- ) 996 prim prim-c-code 2@ s" SET_IP" search if 997 ." SUPER_END;" cr 998 endif 999 2drop ; 1000 1001 1002defer output-nextp0 1003:noname ( -- ) 1004 ." NEXT_P0;" cr ; 1005is output-nextp0 1006 1007defer output-nextp1 1008:noname ( -- ) 1009 ." NEXT_P1;" cr ; 1010is output-nextp1 1011 1012: output-nextp2 ( -- ) 1013 ." NEXT_P2;" cr ; 1014 1015variable tail-nextp2 \ xt to execute for printing NEXT_P2 in INST_TAIL 1016' output-nextp2 tail-nextp2 ! 1017 1018: output-label2 ( -- ) 1019 ." LABEL2(" prim prim-c-name 2@ type ." )" cr 1020 ." NEXT_P1_5;" cr 1021 ." LABEL3(" prim prim-c-name 2@ type ." )" cr 1022 ." DO_GOTO;" cr ; 1023 1024: output-c-tail1 { xt -- } 1025 \ the final part of the generated C code, with xt printing LABEL2 or not. 1026 output-super-end 1027 print-debug-results 1028 output-nextp1 1029 stack-pointer-updates2 1030 stores 1031 fill-state 1032 xt execute ; 1033 1034: output-c-vm-jump-tail ( -- ) 1035 \ !! this functionality not yet implemented for superinstructions 1036 output-super-end 1037 print-debug-results 1038 stores 1039 fill-state 1040 ." LABEL2(" prim prim-c-name 2@ type ." )" cr 1041 ." LABEL3(" prim prim-c-name 2@ type ." )" cr 1042 ." DO_GOTO;" cr ; 1043 1044: output-c-tail1-no-stores { xt -- } 1045 \ the final part of the generated C code for combinations 1046 output-super-end 1047 output-nextp1 1048 fill-state 1049 xt execute ; 1050 1051: output-c-tail ( -- ) 1052 tail-nextp2 @ output-c-tail1 ; 1053 1054: output-c-tail2 ( -- ) 1055 prim prim-c-code 2@ s" VM_JUMP(" search nip nip if 1056 output-c-vm-jump-tail 1057 else 1058 ['] output-label2 output-c-tail1 1059 endif ; 1060 1061: output-c-tail-no-stores ( -- ) 1062 tail-nextp2 @ output-c-tail1-no-stores ; 1063 1064: output-c-tail2-no-stores ( -- ) 1065 prim prim-c-code 2@ s" VM_JUMP(" search nip nip abort" Currently VM_JUMP is not supported in static superinstructions" 1066 ['] output-label2 output-c-tail1-no-stores ; 1067 1068: type-c-code ( c-addr u xt -- ) 1069 \ like TYPE, but replaces "INST_TAIL;" with tail code produced by xt 1070 { xt } 1071 ." {" cr 1072 ." #line " c-line @ . quote c-filename 2@ type quote cr 1073 begin ( c-addr1 u1 ) 1074 2dup s" INST_TAIL;" search 1075 while ( c-addr1 u1 c-addr3 u3 ) 1076 2dup 2>r drop nip over - type 1077 xt execute 1078 2r> 10 /string 1079 \ !! resync #line missing 1080 repeat 1081 2drop type 1082 ." #line " out-nls @ 2 + . quote out-filename 2@ type quote cr 1083 ." }" cr ; 1084 1085: print-entry ( -- ) 1086 ." LABEL(" prim prim-c-name 2@ type ." )" ; 1087 1088: prim-type ( addr u -- ) 1089 \ print out a primitive, but avoid "*/" 1090 2dup s" */" search nip nip IF 1091 bounds ?DO I c@ dup '* = IF drop 'x THEN emit LOOP 1092 ELSE type THEN ; 1093 1094: output-c ( -- ) 1095 print-entry ." /* " prim prim-name 2@ prim-type 1096 ." ( " prim prim-stack-string 2@ type ." ) " 1097 state-in .state ." -- " state-out .state ." */" cr 1098 ." /* " prim prim-doc 2@ type ." */" cr 1099 ." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging 1100 ." {" cr 1101 ." DEF_CA" cr 1102 print-declarations 1103 output-nextp0 1104 spill-state 1105 fetches 1106 print-debug-args 1107 stack-pointer-updates 1108 prim prim-c-code 2@ ['] output-c-tail type-c-code 1109 output-c-tail2 1110 ." }" cr 1111 cr 1112; 1113 1114: disasm-arg { item -- } 1115 item item-stack @ inst-stream = if 1116 ." {" cr 1117 item print-declaration 1118 item fetch 1119 item print-debug-arg 1120 ." }" cr 1121 endif ; 1122 1123: disasm-args ( -- ) 1124 prim prim-effect-in prim prim-effect-in-end @ ['] disasm-arg map-items ; 1125 1126: output-disasm ( -- ) 1127 \ generate code for disassembling VM instructions 1128 ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr 1129 ." fputs(" quote prim prim-name 2@ type quote ." , vm_out);" cr 1130 disasm-args 1131 ." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr 1132 ." goto _endif_;" cr 1133 ." }" cr ; 1134 1135: output-profile ( -- ) 1136 \ generate code for postprocessing the VM block profile stuff 1137 ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr 1138 ." add_inst(b, " quote prim prim-name 2@ type quote ." );" cr 1139 ." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr 1140 prim prim-c-code 2@ s" SET_IP" search nip nip 1141 prim prim-c-code 2@ s" SUPER_END" search nip nip or if 1142 ." return;" cr 1143 else 1144 ." goto _endif_;" cr 1145 endif 1146 ." }" cr ; 1147 1148: output-profile-part ( p ) 1149 ." add_inst(b, " quote 1150 prim-name 2@ type 1151 quote ." );" cr ; 1152 1153: output-profile-combined ( -- ) 1154 \ generate code for postprocessing the VM block profile stuff 1155 ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr 1156 ['] output-profile-part map-combined 1157 ." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr 1158 combined-prims num-combined @ 1- th @ prim-c-code 2@ s" SET_IP" search nip nip 1159 combined-prims num-combined @ 1- th @ prim-c-code 2@ s" SUPER_END" search nip nip or if 1160 ." return;" cr 1161 else 1162 ." goto _endif_;" cr 1163 endif 1164 ." }" cr ; 1165 1166: prim-branch? { prim -- f } 1167 \ true if prim is a branch or super-end 1168 prim prim-c-code 2@ s" SET_IP" search nip nip 0<> ; 1169 1170: output-superend ( -- ) 1171 \ output flag specifying whether the current word ends a dynamic superinst 1172 prim prim-branch? 1173 prim prim-c-code 2@ s" SUPER_END" search nip nip 0<> or 1174 prim prim-c-code 2@ s" SUPER_CONTINUE" search nip nip 0= and 1175 negate 0 .r ." , /* " prim prim-name 2@ prim-type ." */" cr ; 1176 1177: gen-arg-parm { item -- } 1178 item item-stack @ inst-stream = if 1179 ." , " item item-type @ type-c-name 2@ type space 1180 item item-name 2@ type 1181 endif ; 1182 1183: gen-args-parm ( -- ) 1184 prim prim-effect-in prim prim-effect-in-end @ ['] gen-arg-parm map-items ; 1185 1186: gen-arg-gen { item -- } 1187 item item-stack @ inst-stream = if 1188 ." genarg_" item item-type @ print-type-prefix 1189 ." (ctp, " item item-name 2@ type ." );" cr 1190 endif ; 1191 1192: gen-args-gen ( -- ) 1193 prim prim-effect-in prim prim-effect-in-end @ ['] gen-arg-gen map-items ; 1194 1195: output-gen ( -- ) 1196 \ generate C code for generating VM instructions 1197 ." void gen_" prim prim-c-name 2@ type ." (" 1198 threaded-code-pointer-type 2@ type ." ctp" gen-args-parm ." )" cr 1199 ." {" cr 1200 ." gen_inst(ctp, " function-number @ 0 .r ." );" cr 1201 gen-args-gen 1202 ." }" cr ; 1203 1204: stack-used? { stack -- f } 1205 stack stack-in @ stack stack-out @ or 0<> ; 1206 1207: output-funclabel ( -- ) 1208 ." &I_" prim prim-c-name 2@ type ." ," cr ; 1209 1210: output-forthname ( -- ) 1211 '" emit prim prim-name 2@ type '" emit ." ," cr ; 1212 1213\ : output-c-func ( -- ) 1214\ \ used for word libraries 1215\ ." Cell * I_" prim prim-c-name 2@ type ." (Cell *SP, Cell **FP) /* " prim prim-name 2@ type 1216\ ." ( " prim prim-stack-string 2@ type ." ) */" cr 1217\ ." /* " prim prim-doc 2@ type ." */" cr 1218\ ." NAME(" quote prim prim-name 2@ type quote ." )" cr 1219\ \ debugging 1220\ ." {" cr 1221\ print-declarations 1222\ \ !! don't know what to do about that 1223\ inst-stream stack-used? IF ." Cell *ip=IP;" cr THEN 1224\ data-stack stack-used? IF ." Cell *sp=SP;" cr THEN 1225\ fp-stack stack-used? IF ." Cell *fp=*FP;" cr THEN 1226\ return-stack stack-used? IF ." Cell *rp=*RP;" cr THEN 1227\ spill-state 1228\ fetches 1229\ stack-pointer-updates 1230\ fp-stack stack-used? IF ." *FP=fp;" cr THEN 1231\ ." {" cr 1232\ ." #line " c-line @ . quote c-filename 2@ type quote cr 1233\ prim prim-c-code 2@ type 1234\ ." }" cr 1235\ stores 1236\ fill-state 1237\ ." return (sp);" cr 1238\ ." }" cr 1239\ cr ; 1240 1241: output-label ( -- ) 1242 ." INST_ADDR(" prim prim-c-name 2@ type ." )," cr ; 1243 1244: output-alias ( -- ) 1245 ( primitive-number @ . ." alias " ) ." Primitive " prim prim-name 2@ type cr ; 1246 1247defer output-c-prim-num ( -- ) 1248 1249:noname ( -- ) 1250 ." N_" prim prim-c-name 2@ type ." ," cr ; 1251is output-c-prim-num 1252 1253: output-forth ( -- ) 1254 prim prim-forth-code @ 0= 1255 IF \ output-alias 1256 \ this is bad for ec: an alias is compiled if tho word does not exist! 1257 \ JAW 1258 ELSE ." : " prim prim-name 2@ type ." ( " 1259 prim prim-stack-string 2@ type ." )" cr 1260 prim prim-forth-code 2@ type cr 1261 THEN ; 1262 1263: output-tag-file ( -- ) 1264 name-filename 2@ last-name-filename 2@ compare if 1265 name-filename 2@ last-name-filename 2! 1266 #ff emit cr 1267 name-filename 2@ type 1268 ." ,0" cr 1269 endif ; 1270 1271: output-tag ( -- ) 1272 output-tag-file 1273 prim prim-name 2@ 1+ type 1274 127 emit 1275 space prim prim-name 2@ type space 1276 1 emit 1277 name-line @ 0 .r 1278 ." ,0" cr ; 1279 1280: output-vi-tag ( -- ) 1281 name-filename 2@ type #tab emit 1282 prim prim-name 2@ type #tab emit 1283 ." /^" prim prim-name 2@ type ." *(/" cr ; 1284 1285[IFDEF] documentation 1286: register-doc ( -- ) 1287 prim prim-name 2@ documentation ['] create insert-wordlist 1288 prim prim-name 2@ 2, 1289 prim prim-stack-string 2@ condition-stack-effect 2, 1290 prim prim-wordset 2@ 2, 1291 prim prim-c-name 2@ condition-pronounciation 2, 1292 prim prim-doc 2@ 2, ; 1293[THEN] 1294 1295 1296\ combining instructions 1297 1298\ The input should look like this: 1299 1300\ lit_+ = lit + 1301 1302\ The output should look like this: 1303 1304\ I_lit_+: 1305\ { 1306\ DEF_CA 1307\ Cell _x_ip0; 1308\ Cell _x_sp0; 1309\ Cell _x_sp1; 1310\ NEXT_P0; 1311\ _x_ip0 = (Cell) IPTOS; 1312\ _x_sp0 = (Cell) spTOS; 1313\ INC_IP(1); 1314\ /* sp += 0; */ 1315\ /* lit ( #w -- w ) */ 1316\ /* */ 1317\ NAME("lit") 1318\ { 1319\ Cell w; 1320\ w = (Cell) _x_ip0; 1321\ #ifdef VM_DEBUG 1322\ if (vm_debug) { 1323\ fputs(" w=", vm_out); printarg_w (w); 1324\ fputc('\n', vm_out); 1325\ } 1326\ #endif 1327\ { 1328\ #line 136 "./prim" 1329\ } 1330\ _x_sp1 = (Cell)w; 1331\ } 1332\ I_plus: /* + ( n1 n2 -- n ) */ 1333\ /* */ 1334\ NAME("+") 1335\ { 1336\ DEF_CA 1337\ Cell n1; 1338\ Cell n2; 1339\ Cell n; 1340\ NEXT_P0; 1341\ n1 = (Cell) _x_sp0; 1342\ n2 = (Cell) _x_sp1; 1343\ #ifdef VM_DEBUG 1344\ if (vm_debug) { 1345\ fputs(" n1=", vm_out); printarg_n (n1); 1346\ fputs(" n2=", vm_out); printarg_n (n2); 1347\ fputc('\n', vm_out); 1348\ } 1349\ #endif 1350\ { 1351\ #line 516 "./prim" 1352\ n = n1+n2; 1353\ } 1354\ _x_sp0 = (Cell)n; 1355\ } 1356\ NEXT_P1; 1357\ spTOS = (Cell)_x_sp0; 1358\ NEXT_P2; 1359 1360: init-combined ( -- ) 1361 ['] clear-prim-stacks-sync map-stacks 1362 prim to combined 1363 0 num-combined ! 1364 current-depth max-stacks cells erase 1365 include-skipped-insts @ current-depth 0 th ! 1366 max-depth max-stacks cells erase 1367 min-depth max-stacks cells erase 1368 prim prim-effect-in prim prim-effect-in-end ! 1369 prim prim-effect-out prim prim-effect-out-end ! ; 1370 1371: max! ( n addr -- ) 1372 tuck @ max swap ! ; 1373 1374: min! ( n addr -- ) 1375 tuck @ min swap ! ; 1376 1377: inst-stream-adjustment ( nstack -- n ) 1378 \ number of stack items to add for each part 1379 0= include-skipped-insts @ and negate ; 1380 1381: add-depths { p -- } 1382 \ combine stack effect of p with *-depths 1383 max-stacks 0 ?do 1384 current-depth i th @ 1385 p prim-stacks-in i th @ + i inst-stream-adjustment + 1386 dup max-depth i th max! 1387 p prim-stacks-out i th @ - 1388 dup min-depth i th min! 1389 current-depth i th ! 1390 loop ; 1391 1392: copy-maxdepths ( n -- ) 1393 max-depth max-depths rot max-stacks * th max-stacks cells move ; 1394 1395: add-prim ( addr u -- ) 1396 \ add primitive given by "addr u" to combined-prims 1397 primitives search-wordlist s" unknown primitive" ?print-error 1398 execute { p } 1399 p combined-prims num-combined @ th ! 1400 num-combined @ copy-maxdepths 1401 1 num-combined +! 1402 p add-depths 1403 num-combined @ copy-maxdepths ; 1404 1405: compute-effects { q -- } 1406 \ compute the stack effects of q from the depths 1407 max-stacks 0 ?do 1408 max-depth i th @ dup 1409 q prim-stacks-in i th ! 1410 current-depth i th @ - 1411 q prim-stacks-out i th ! 1412 loop ; 1413 1414: make-effect-items { stack# items effect-endp -- } 1415 \ effect-endp points to a pointer to the end of the current item-array 1416 \ and has to be updated 1417 stacks stack# th @ { stack } 1418 items 0 +do 1419 effect-endp @ { item } 1420 i 0 <# #s stack stack-pointer 2@ holds [char] _ hold #> save-mem 1421 item item-name 2! 1422 stack item item-stack ! 1423 stack stack-type @ item item-type ! 1424 i item item-offset ! 1425 item item-first on 1426 item% %size effect-endp +! 1427 loop ; 1428 1429: init-effects { q -- } 1430 \ initialize effects field for FETCHES and STORES 1431 max-stacks 0 ?do 1432 i q prim-stacks-in i th @ q prim-effect-in-end make-effect-items 1433 i q prim-stacks-out i th @ q prim-effect-out-end make-effect-items 1434 loop ; 1435 1436: compute-stack-max-back-depths ( stack -- ) 1437 stack-number @ { stack# } 1438 current-depth stack# th @ dup 1439 dup stack# num-combined @ s-c-max-back-depth ! 1440 -1 num-combined @ 1- -do ( max-depth current-depth ) 1441 combined-prims i th @ { p } 1442 p prim-stacks-out stack# th @ + 1443 dup >r max r> 1444 over stack# i s-c-max-back-depth ! 1445 p prim-stacks-in stack# th @ - 1446 stack# inst-stream-adjustment - 1447 1 -loop 1448 assert( dup stack# inst-stream-adjustment negate = ) 1449 assert( over max-depth stack# th @ = ) 1450 2drop ; 1451 1452: compute-max-back-depths ( -- ) 1453 \ compute max-back-depths. 1454 \ assumes that current-depths is correct for the end of the combination 1455 ['] compute-stack-max-back-depths map-stacks ; 1456 1457: process-combined ( -- ) 1458 combined combined-prims num-combined @ cells 1459 combinations ['] constant insert-wordlist 1460 combined-prims num-combined @ 1- th ( last-part ) 1461 @ prim-c-code 2@ prim prim-c-code 2! \ used by output-super-end 1462 prim compute-effects 1463 prim init-effects 1464 compute-max-back-depths 1465 output-combined perform ; 1466 1467\ reprocessing (typically to generate versions for another cache states) 1468\ !! use prim-context 1469 1470variable reprocessed-num 0 reprocessed-num ! 1471 1472: new-name ( -- c-addr u ) 1473 reprocessed-num @ 0 1474 1 reprocessed-num +! 1475 <# #s 'p hold '_ hold #> save-mem ; 1476 1477: reprocess-simple ( prim -- ) 1478 to prim 1479 new-name prim prim-c-name 2! 1480 output @ execute ; 1481 1482: lookup-prim ( c-addr u -- prim ) 1483 primitives search-wordlist 0= -13 and throw execute ; 1484 1485: state-prim1 { in-state out-state prim -- } 1486 in-state out-state state-default dup d= ?EXIT 1487 in-state state-enabled? out-state state-enabled? and 0= ?EXIT 1488 in-state to state-in 1489 out-state to state-out 1490 prim reprocess-simple ; 1491 1492: state-prim ( in-state out-state "name" -- ) 1493 parse-word lookup-prim state-prim1 ; 1494 1495\ reprocessing with default states 1496 1497\ This is a simple scheme and should be generalized 1498\ assumes we only cache one stack and use simple states for that 1499 15000 value cache-stack \ stack that we cache 15012variable cache-states \ states of the cache, starting with the empty state 1502 1503: compute-default-state-out ( n-in -- n-out ) 1504 \ for the current prim 1505 cache-stack stack-in @ - 0 max 1506 cache-stack stack-prim-stacks-sync @ if 1507 drop 0 1508 endif 1509 cache-stack stack-out @ + cache-states 2@ nip 1- min ; 1510 1511: gen-prim-states ( prim -- ) 1512 to prim 1513 cache-states 2@ swap { states } ( nstates ) 1514 cache-stack stack-in @ +do 1515 states i th @ 1516 states i compute-default-state-out th @ 1517 prim state-prim1 1518 loop ; 1519 1520: prim-states ( "name" -- ) 1521 parse-word lookup-prim gen-prim-states ; 1522 1523: gen-branch-states ( prim -- ) 1524 \ generate versions that produce state-default; useful for branches 1525 to prim 1526 cache-states 2@ swap { states } ( nstates ) 1527 cache-stack stack-in @ +do 1528 states i th @ state-default prim state-prim1 1529 loop ; 1530 1531: branch-states ( out-state "name" -- ) 1532 parse-word lookup-prim gen-branch-states ; 1533 1534\ producing state transitions 1535 1536: gen-transitions ( "name" -- ) 1537 parse-word lookup-prim { prim } 1538 cache-states 2@ { states nstates } 1539 nstates 0 +do 1540 nstates 0 +do 1541 i j <> if 1542 states i th @ states j th @ prim state-prim1 1543 endif 1544 loop 1545 loop ; 1546 1547\ C output 1548 1549: print-item { n stack -- } 1550 \ print nth stack item name 1551 stack stack-type @ type-c-name 2@ type space 1552 ." MAYBE_UNUSED _" stack stack-pointer 2@ type n 0 .r ; 1553 1554: print-declarations-combined ( -- ) 1555 max-stacks 0 ?do 1556 max-depth i th @ min-depth i th @ - 0 +do 1557 i stacks j th @ print-item ." ;" cr 1558 loop 1559 loop ; 1560 1561: part-fetches ( -- ) 1562 fetches ; 1563 1564: part-output-c-tail ( -- ) 1565 print-debug-results 1566 stores ; 1567 1568: output-combined-tail ( -- ) 1569 in-part @ >r in-part off 1570 part-output-c-tail 1571 combined ['] output-c-tail-no-stores prim-context 1572 r> in-part ! ; 1573 1574: part-stack-pointer-updates ( -- ) 1575 next-stack-number @ 0 +do 1576 i part-num @ 1+ s-c-max-depth @ dup 1577 i num-combined @ s-c-max-depth @ = \ final depth 1578 swap i part-num @ s-c-max-depth @ <> \ just reached now 1579 part-num @ 0= \ first part 1580 or and if 1581 stacks i th @ stack-pointer-update 1582 endif 1583 loop ; 1584 1585: output-part ( p -- ) 1586 to prim 1587 ." /* " prim prim-name 2@ prim-type ." ( " prim prim-stack-string 2@ type ." ) */" cr 1588 ." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging 1589 ." {" cr 1590 print-declarations 1591 part-fetches 1592 print-debug-args 1593 combined ['] part-stack-pointer-updates prim-context 1594 1 part-num +! 1595 prim add-depths \ !! right place? 1596 prim prim-c-code 2@ ['] output-combined-tail type-c-code 1597 part-output-c-tail 1598 ." }" cr ; 1599 1600: output-parts ( -- ) 1601 prim >r in-part on 1602 current-depth max-stacks cells erase 1603 0 part-num ! 1604 ['] output-part map-combined 1605 in-part off 1606 r> to prim ; 1607 1608: output-c-combined ( -- ) 1609 print-entry cr 1610 \ debugging messages just in parts 1611 ." {" cr 1612 ." DEF_CA" cr 1613 print-declarations-combined 1614 output-nextp0 1615 spill-state 1616 \ fetches \ now in parts 1617 \ print-debug-args 1618 \ stack-pointer-updates now in parts 1619 output-parts 1620 output-c-tail2-no-stores 1621 ." }" cr 1622 cr ; 1623 1624: output-forth-combined ( -- ) 1625; 1626 1627 1628\ peephole optimization rules 1629 1630\ data for a simple peephole optimizer that always tries to combine 1631\ the currently compiled instruction with the last one. 1632 1633\ in order for this to work as intended, shorter combinations for each 1634\ length must be present, and the longer combinations must follow 1635\ shorter ones (this restriction may go away in the future). 1636 1637: output-peephole ( -- ) 1638 combined-prims num-combined @ 1- cells combinations search-wordlist 1639 s" the prefix for this superinstruction must be defined earlier" ?print-error 1640 ." {" 1641 execute prim-num @ 5 .r ." ," 1642 combined-prims num-combined @ 1- th @ prim-num @ 5 .r ." ," 1643 combined prim-num @ 5 .r ." }, /* " 1644 combined prim-c-name 2@ type ." */" 1645 cr ; 1646 1647 1648\ cost and superinstruction data for a sophisticated combiner (e.g., 1649\ shortest path) 1650 1651\ This is intended as initializer for a structure like this 1652 1653\ struct cost { 1654\ char loads; /* number of stack loads */ 1655\ char stores; /* number of stack stores */ 1656\ char updates; /* number of stack pointer updates */ 1657\ char branch; /* is it a branch (SET_IP) */ 1658\ char state_in; /* state on entry */ 1659\ char state_out; /* state on exit */ 1660\ short offset; /* offset into super2 table */ 1661\ char length; /* number of components */ 1662\ }; 1663 1664\ How do you know which primitive or combined instruction this 1665\ structure refers to? By the order of cost structures, as in most 1666\ other cases. 1667 1668: super2-length ( -- n ) 1669 combined if 1670 num-combined @ 1671 else 1672 1 1673 endif ; 1674 1675: compute-costs { p -- nloads nstores nupdates } 1676 \ compute the number of loads, stores, and stack pointer updates 1677 \ of a primitive or combined instruction; does not take TOS 1678 \ caching into account 1679 0 max-stacks 0 +do 1680 p prim-stacks-in i th @ + 1681 loop 1682 super2-length 1- - \ don't count instruction fetches of subsumed insts 1683 0 max-stacks 0 +do 1684 p prim-stacks-out i th @ + 1685 loop 1686 0 max-stacks 1 +do \ don't count ip updates, therefore "1 +do" 1687 p prim-stacks-in i th @ p prim-stacks-out i th @ <> - 1688 loop ; 1689 1690: output-num-part ( p -- ) 1691 ." N_" prim-c-name-orig 2@ type ." ," ; 1692 \ prim-num @ 4 .r ." ," ; 1693 1694: output-name-comment ( -- ) 1695 ." /* " prim prim-name 2@ prim-type ." */" ; 1696 1697variable offset-super2 0 offset-super2 ! \ offset into the super2 table 1698 1699: output-costs-prefix ( -- ) 1700 ." {" prim compute-costs 1701 rot 2 .r ." ," swap 2 .r ." ," 2 .r ." , " 1702 prim prim-branch? negate . ." ," 1703 state-in state-number @ 2 .r ." ," 1704 state-out state-number @ 2 .r ." ," 1705 inst-stream stack-in @ 1 .r ." ," 1706; 1707 1708: output-costs-gforth-simple ( -- ) 1709 output-costs-prefix 1710 prim output-num-part 1711 1 2 .r ." }," 1712 output-name-comment 1713 cr ; 1714 1715: output-costs-gforth-combined ( -- ) 1716 output-costs-prefix 1717 ." N_START_SUPER+" offset-super2 @ 5 .r ." ," 1718 super2-length dup 2 .r ." }," offset-super2 +! 1719 output-name-comment 1720 cr ; 1721 1722\ : output-costs ( -- ) 1723\ \ description of superinstructions and simple instructions 1724\ ." {" prim compute-costs 1725\ rot 2 .r ." ," swap 2 .r ." ," 2 .r ." ," 1726\ offset-super2 @ 5 .r ." ," 1727\ super2-length dup 2 .r ." ," offset-super2 +! 1728\ inst-stream stack-in @ 1 .r ." }," 1729\ output-name-comment 1730\ cr ; 1731 1732: output-super2-simple ( -- ) 1733 prim prim-c-name 2@ prim prim-c-name-orig 2@ d= if 1734 prim output-num-part 1735 output-name-comment 1736 cr 1737 endif ; 1738 1739: output-super2-combined ( -- ) 1740 ['] output-num-part map-combined 1741 output-name-comment 1742 cr ; 1743 1744\ the parser 1745 1746eof-char max-member \ the whole character set + EOF 1747 1748: getinput ( -- n ) 1749 rawinput @ endrawinput @ = 1750 if 1751 eof-char 1752 else 1753 cookedinput @ c@ 1754 endif ; 1755 1756:noname ( n -- ) 1757 dup bl > if 1758 emit space 1759 else 1760 . 1761 endif ; 1762print-token ! 1763 1764: testchar? ( set -- f ) 1765 getinput member? ; 1766' testchar? test-vector ! 1767 1768: checksynclines ( -- ) 1769 \ when input points to a newline, check if the next line is a 1770 \ sync line. If it is, perform the appropriate actions. 1771 rawinput @ begin >r 1772 s" #line " r@ over compare if 1773 rdrop 1 line +! EXIT 1774 endif 1775 0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr ) 1776 dup c@ bl = if 1777 char+ dup c@ [char] " <> 0= s" sync line syntax" ?print-error 1778 char+ dup 100 [char] " scan drop swap 2dup - save-mem filename 2! 1779 char+ 1780 endif 1781 dup c@ nl-char <> 0= s" sync line syntax" ?print-error 1782 skipsynclines @ if 1783 char+ dup rawinput ! 1784 rawinput @ c@ cookedinput @ c! 1785 endif 1786 again ; 1787 1788: ?nextchar ( f -- ) 1789 s" syntax error, wrong char" ?print-error 1790 rawinput @ endrawinput @ <> if 1791 rawinput @ c@ 1792 1 chars rawinput +! 1793 1 chars cookedinput +! 1794 nl-char = if 1795 checksynclines 1796 rawinput @ line-start ! 1797 endif 1798 rawinput @ c@ 1799 cookedinput @ c! 1800 endif ; 1801 1802: charclass ( set "name" -- ) 1803 ['] ?nextchar terminal ; 1804 1805: .. ( c1 c2 -- set ) 1806 ( creates a set that includes the characters c, c1<=c<=c2 ) 1807 empty copy-set 1808 swap 1+ rot do 1809 i over add-member 1810 loop ; 1811 1812: ` ( -- terminal ) ( use: ` c ) 1813 ( creates anonymous terminal for the character c ) 1814 char singleton ['] ?nextchar make-terminal ; 1815 1816char a char z .. char A char Z .. union char _ singleton union charclass letter 1817char 0 char 9 .. charclass digit 1818bl singleton tab-char over add-member charclass white 1819nl-char singleton eof-char over add-member complement charclass nonl 1820nl-char singleton eof-char over add-member 1821 char : over add-member complement charclass nocolonnl 1822nl-char singleton eof-char over add-member 1823 char } over add-member complement charclass nobracenl 1824bl 1+ maxchar .. char \ singleton complement intersection 1825 charclass nowhitebq 1826bl 1+ maxchar .. charclass nowhite 1827char " singleton eof-char over add-member complement charclass noquote 1828nl-char singleton charclass nl 1829eof-char singleton charclass eof 1830nl-char singleton eof-char over add-member charclass nleof 1831 1832(( letter (( letter || digit )) ** 1833)) <- c-ident ( -- ) 1834 1835(( ` . ` . ` . 1836)) <- sync-stack ( -- ) 1837 1838(( ` # ?? (( letter || digit || ` : )) ++ sync-stack ?? 1839|| sync-stack 1840)) <- stack-ident ( -- ) 1841 1842(( nowhitebq nowhite ** )) 1843<- forth-ident ( -- ) 1844 1845Variable forth-flag 1846Variable c-flag 1847 1848(( (( ` e || ` E )) {{ start }} nonl ** 1849 {{ end evaluate }} 1850)) <- eval-comment ( ... -- ... ) 1851 1852(( (( ` f || ` F )) {{ start }} nonl ** 1853 {{ end forth-flag @ IF type cr ELSE 2drop THEN }} 1854)) <- forth-comment ( -- ) 1855 1856(( (( ` c || ` C )) {{ start }} nonl ** 1857 {{ end c-flag @ IF type cr ELSE 2drop THEN }} 1858)) <- c-comment ( -- ) 1859 1860(( ` - nonl ** {{ 1861 forth-flag @ IF forth-fdiff ." [ELSE]" cr THEN 1862 c-flag @ IF 1863 function-diff 1864 ." #else /* " function-number @ 0 .r ." */" cr THEN }} 1865)) <- else-comment 1866 1867(( ` + {{ start }} nonl ** {{ end 1868 dup 1869 IF 1870 c-flag @ IF 1871 function-diff 1872 ." #ifdef HAS_" 2dup bounds ?DO I c@ toupper emit LOOP cr 1873 THEN 1874 forth-flag @ IF 1875 forth-fdiff ." has? " 2dup type ." [IF]" cr 1876 THEN 1877 2drop 1878 ELSE 1879 2drop 1880 c-flag @ IF 1881 function-diff ." #endif" cr THEN 1882 forth-flag @ IF forth-fdiff ." [THEN]" cr THEN 1883 THEN }} 1884)) <- if-comment 1885 1886(( (( ` g || ` G )) {{ start }} nonl ** 1887 {{ end 1888 forth-flag @ IF forth-fdiff ." group " 2dup type cr THEN 1889 c-flag @ IF function-diff 1890 ." GROUP(" 2dup type ." , " function-number @ 0 .r ." )" cr THEN 1891 2drop }} 1892)) <- group-comment 1893 1894(( (( eval-comment || forth-comment || c-comment || else-comment || if-comment || group-comment )) ?? nonl ** )) <- comment-body 1895 1896(( ` \ comment-body nleof )) <- comment ( -- ) 1897 1898(( {{ start }} stack-ident {{ end init-item1 }} white ** )) ** 1899<- stack-items ( addr1 -- addr2 ) 1900 1901(( {{ prim prim-effect-in }} stack-items {{ prim prim-effect-in-end ! }} 1902 ` - ` - white ** 1903 {{ prim prim-effect-out }} stack-items {{ prim prim-effect-out-end ! }} 1904)) <- stack-effect ( -- ) 1905 1906(( {{ prim create-prim prim init-simple }} 1907 ` ( white ** {{ start }} stack-effect {{ end prim prim-stack-string 2! }} ` ) white ** 1908 (( {{ start }} forth-ident {{ end prim prim-wordset 2! }} white ** 1909 (( {{ start }} c-ident {{ end prim-c-name-2! }} )) ?? 1910 )) ?? nleof 1911 (( ` " ` " {{ start }} (( noquote ++ ` " )) ++ {{ end 1- prim prim-doc 2! }} ` " white ** nleof )) ?? 1912 {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} 1913 (( (( ` { nonl ** nleof (( (( nobracenl {{ line @ drop }} nonl ** )) ?? nleof )) ** ` } white ** nleof white ** )) 1914 || (( nocolonnl nonl ** nleof white ** )) ** )) 1915 {{ end prim prim-c-code 2! skipsynclines on }} 1916 (( ` : white ** nleof 1917 {{ start }} (( nonl ++ nleof white ** )) ++ {{ end prim prim-forth-code 2! }} 1918 )) ?? {{ process-simple }} 1919 nleof 1920)) <- simple-primitive ( -- ) 1921 1922(( {{ init-combined }} 1923 ` = white ** (( {{ start }} forth-ident {{ end add-prim }} white ** )) ++ 1924 nleof {{ process-combined }} 1925)) <- combined-primitive 1926 1927(( {{ make-prim to prim 0 to combined 1928 line @ name-line ! filename 2@ name-filename 2! 1929 function-number @ prim prim-num ! 1930 start }} [ifdef] vmgen c-ident [else] forth-ident [then] {{ end 1931 2dup prim prim-name 2! prim-c-name-2! }} white ** 1932 (( ` / white ** {{ start }} c-ident {{ end prim-c-name-2! }} white ** )) ?? 1933 (( simple-primitive || combined-primitive )) 1934 {{ 1 function-number +! }} 1935)) <- primitive ( -- ) 1936 1937(( (( comment || primitive || nl white ** )) ** eof )) 1938parser primitives2something 1939warnings @ [IF] 1940.( parser generated ok ) cr 1941[THEN] 1942 1943 1944\ run with gforth-0.5.0 (slurp-file is missing) 1945[IFUNDEF] slurp-file 1946: slurp-file ( c-addr1 u1 -- c-addr2 u2 ) 1947 \ c-addr1 u1 is the filename, c-addr2 u2 is the file's contents 1948 r/o bin open-file throw >r 1949 r@ file-size throw abort" file too large" 1950 dup allocate throw swap 1951 2dup r@ read-file throw over <> abort" could not read whole file" 1952 r> close-file throw ; 1953[THEN] 1954 1955: primfilter ( addr u -- ) 1956 \ process the string at addr u 1957 over dup rawinput ! dup line-start ! cookedinput ! 1958 + endrawinput ! 1959 checksynclines 1960 primitives2something ; 1961 1962: unixify ( c-addr u1 -- c-addr u2 ) 1963 \ delete crs from the string 1964 bounds tuck tuck ?do ( c-addr1 ) 1965 i c@ dup #cr <> if 1966 over c! char+ 1967 else 1968 drop 1969 endif 1970 loop 1971 over - ; 1972 1973: process-file ( addr u xt-simple x-combined -- ) 1974 output-combined ! output ! 1975 save-mem 2dup filename 2! 1976 slurp-file unixify 1977 warnings @ if 1978 ." ------------ CUT HERE -------------" cr endif 1979 primfilter ; 1980 1981\ : process ( xt -- ) 1982\ bl word count rot 1983\ process-file ; 1984