Annotation of gforth/prims2x0.6.2.fs, revision 1.1
1.1 ! anton 1: \ converts primitives to, e.g., C code
! 2:
! 3: \ Copyright (C) 1995,1996,1997,1998,2000,2003 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 2
! 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, write to the Free Software
! 19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
! 20:
! 21:
! 22: \ This is not very nice (hard limits, no checking, assumes 1 chars = 1).
! 23: \ And it grew even worse when it aged.
! 24:
! 25: \ Optimizations:
! 26: \ superfluous stores are removed. GCC removes the superfluous loads by itself
! 27: \ TOS and FTOS can be kept in register( variable)s.
! 28: \
! 29: \ Problems:
! 30: \ The TOS optimization is somewhat hairy. The problems by example:
! 31: \ 1) dup ( w -- w w ): w=TOS; sp-=1; sp[1]=w; TOS=w;
! 32: \ The store is not superfluous although the earlier opt. would think so
! 33: \ Alternatively: sp[0]=TOS; w=TOS; sp-=1; TOS=w;
! 34: \ 2) ( -- .. ): sp[0] = TOS; ... /* This additional store is necessary */
! 35: \ 3) ( .. -- ): ... TOS = sp[0]; /* as well as this load */
! 36: \ 4) ( -- ): /* but here they are unnecessary */
! 37: \ 5) Words that call NEXT themselves have to be done very carefully.
! 38: \
! 39: \ To do:
! 40: \ add the store optimization for doubles
! 41: \ regarding problem 1 above: It would be better (for over) to implement
! 42: \ the alternative
! 43: \ store optimization for combined instructions.
! 44:
! 45: \ Design Uglyness:
! 46:
! 47: \ - global state (values, variables) in connection with combined instructions.
! 48:
! 49: \ - index computation is different for instruction-stream and the
! 50: \ stacks; there are two mechanisms for dealing with that
! 51: \ (stack-in-index-xt and a test for stack==instruction-stream); there
! 52: \ should be only one.
! 53:
! 54: \ for backwards compatibility, jaw
! 55: require compat/strcomp.fs
! 56:
! 57: warnings off
! 58:
! 59: \ redefinitions of kernel words not present in gforth-0.6.1
! 60: : latestxt lastcfa @ ;
! 61: : latest last @ ;
! 62:
! 63: [IFUNDEF] try
! 64: include startup.fs
! 65: [THEN]
! 66:
! 67: : struct% struct ; \ struct is redefined in gray
! 68:
! 69: warnings off
! 70: \ warnings on
! 71:
! 72: include ./gray.fs
! 73: 128 constant max-effect \ number of things on one side of a stack effect
! 74: 4 constant max-stacks \ the max. number of stacks (including inst-stream).
! 75: 255 constant maxchar
! 76: maxchar 1+ constant eof-char
! 77: #tab constant tab-char
! 78: #lf constant nl-char
! 79:
! 80: variable rawinput \ pointer to next character to be scanned
! 81: variable endrawinput \ pointer to the end of the input (the char after the last)
! 82: variable cookedinput \ pointer to the next char to be parsed
! 83: variable line \ line number of char pointed to by input
! 84: variable line-start \ pointer to start of current line (for error messages)
! 85: 0 line !
! 86: 2variable filename \ filename of original input file
! 87: 0 0 filename 2!
! 88: 2variable out-filename \ filename of the output file (for sync lines)
! 89: 0 0 out-filename 2!
! 90: 2variable f-comment
! 91: 0 0 f-comment 2!
! 92: variable skipsynclines \ are sync lines ("#line ...") invisible to the parser?
! 93: skipsynclines on
! 94: variable out-nls \ newlines in output (for output sync lines)
! 95: 0 out-nls !
! 96: variable store-optimization \ use store optimization?
! 97: store-optimization off
! 98:
! 99: variable include-skipped-insts
! 100: \ does the threaded code for a combined instruction include the cells
! 101: \ for the component instructions (true) or only the cells for the
! 102: \ inline arguments (false)
! 103: include-skipped-insts off
! 104:
! 105: variable immarg \ values for immediate arguments (to be used in IMM_ARG macros)
! 106: $12340000 immarg !
! 107:
! 108: : th ( addr1 n -- addr2 )
! 109: cells + ;
! 110:
! 111: : holds ( addr u -- )
! 112: \ like HOLD, but for a string
! 113: tuck + swap 0 +do
! 114: 1- dup c@ hold
! 115: loop
! 116: drop ;
! 117:
! 118: : insert-wordlist { c-addr u wordlist xt -- }
! 119: \ adds name "addr u" to wordlist using defining word xt
! 120: \ xt may cause additional stack effects
! 121: get-current >r wordlist set-current
! 122: c-addr u nextname xt execute
! 123: r> set-current ;
! 124:
! 125: : start ( -- addr )
! 126: cookedinput @ ;
! 127:
! 128: : end ( addr -- addr u )
! 129: cookedinput @ over - ;
! 130:
! 131: : print-error-line ( -- )
! 132: \ print the current line and position
! 133: line-start @ endrawinput @ over - 2dup nl-char scan drop nip ( start end )
! 134: over - type cr
! 135: line-start @ rawinput @ over - typewhite ." ^" cr ;
! 136:
! 137: : ?print-error { f addr u -- }
! 138: f ?not? if
! 139: outfile-id >r try
! 140: stderr to outfile-id
! 141: filename 2@ type ." :" line @ 0 .r ." : " addr u type cr
! 142: print-error-line
! 143: 0
! 144: endtry-iferror
! 145: then
! 146: r> to outfile-id throw
! 147: 1 (bye) \ abort
! 148: endif ;
! 149:
! 150: : quote ( -- )
! 151: [char] " emit ;
! 152:
! 153: \ count output lines to generate sync lines for output
! 154:
! 155: : count-nls ( addr u -- )
! 156: bounds u+do
! 157: i c@ nl-char = negate out-nls +!
! 158: loop ;
! 159:
! 160: :noname ( addr u -- )
! 161: 2dup count-nls
! 162: defers type ;
! 163: is type
! 164:
! 165: variable output \ xt ( -- ) of output word for simple primitives
! 166: variable output-combined \ xt ( -- ) of output word for combined primitives
! 167:
! 168: struct%
! 169: cell% field stack-number \ the number of this stack
! 170: cell% 2* field stack-pointer \ stackpointer name
! 171: cell% field stack-type \ name for default type of stack items
! 172: cell% field stack-in-index-xt \ ( in-size item -- in-index )
! 173: cell% field stack-access-transform \ ( nitem -- index )
! 174: end-struct stack%
! 175:
! 176: struct%
! 177: cell% 2* field item-name \ name, excluding stack prefixes
! 178: cell% field item-stack \ descriptor for the stack used, 0 is default
! 179: cell% field item-type \ descriptor for the item type
! 180: cell% field item-offset \ offset in stack items, 0 for the deepest element
! 181: cell% field item-first \ true if this is the first occurence of the item
! 182: end-struct item%
! 183:
! 184: struct%
! 185: cell% 2* field type-c-name
! 186: cell% field type-stack \ default stack
! 187: cell% field type-size \ size of type in stack items
! 188: cell% field type-fetch \ xt of fetch code generator ( item -- )
! 189: cell% field type-store \ xt of store code generator ( item -- )
! 190: end-struct type%
! 191:
! 192: variable next-stack-number 0 next-stack-number !
! 193: create stacks max-stacks cells allot \ array of stacks
! 194:
! 195: : stack-in-index ( in-size item -- in-index )
! 196: item-offset @ - 1- ;
! 197:
! 198: : inst-in-index ( in-size item -- in-index )
! 199: nip dup item-offset @ swap item-type @ type-size @ + 1- ;
! 200:
! 201: : make-stack ( addr-ptr u1 type "stack-name" -- )
! 202: next-stack-number @ max-stacks < s" too many stacks" ?print-error
! 203: create stack% %allot >r
! 204: r@ stacks next-stack-number @ th !
! 205: next-stack-number @ r@ stack-number !
! 206: 1 next-stack-number +!
! 207: r@ stack-type !
! 208: save-mem r@ stack-pointer 2!
! 209: ['] stack-in-index r@ stack-in-index-xt !
! 210: ['] noop r@ stack-access-transform !
! 211: rdrop ;
! 212:
! 213: : map-stacks { xt -- }
! 214: \ perform xt for all stacks
! 215: next-stack-number @ 0 +do
! 216: stacks i th @ xt execute
! 217: loop ;
! 218:
! 219: : map-stacks1 { xt -- }
! 220: \ perform xt for all stacks except inst-stream
! 221: next-stack-number @ 1 +do
! 222: stacks i th @ xt execute
! 223: loop ;
! 224:
! 225: \ stack items
! 226:
! 227: : init-item ( addr u addr1 -- )
! 228: \ initialize item at addr1 with name addr u
! 229: \ !! remove stack prefix
! 230: dup item% %size erase
! 231: item-name 2! ;
! 232:
! 233: : map-items { addr end xt -- }
! 234: \ perform xt for all items in array addr...end
! 235: end addr ?do
! 236: i xt execute
! 237: item% %size +loop ;
! 238:
! 239: \ types
! 240:
! 241: : print-type-prefix ( type -- )
! 242: body> >head name>string type ;
! 243:
! 244: \ various variables for storing stuff of one primitive
! 245:
! 246: struct%
! 247: cell% 2* field prim-name
! 248: cell% 2* field prim-wordset
! 249: cell% 2* field prim-c-name
! 250: cell% 2* field prim-doc
! 251: cell% 2* field prim-c-code
! 252: cell% 2* field prim-forth-code
! 253: cell% 2* field prim-stack-string
! 254: cell% field prim-num \ ordinal number
! 255: cell% field prim-items-wordlist \ unique items
! 256: item% max-effect * field prim-effect-in
! 257: item% max-effect * field prim-effect-out
! 258: cell% field prim-effect-in-end
! 259: cell% field prim-effect-out-end
! 260: cell% max-stacks * field prim-stacks-in \ number of in items per stack
! 261: cell% max-stacks * field prim-stacks-out \ number of out items per stack
! 262: end-struct prim%
! 263:
! 264: : make-prim ( -- prim )
! 265: prim% %alloc { p }
! 266: s" " p prim-doc 2! s" " p prim-forth-code 2! s" " p prim-wordset 2!
! 267: p ;
! 268:
! 269: 0 value prim \ in combined prims either combined or a part
! 270: 0 value combined \ in combined prims the combined prim
! 271: variable in-part \ true if processing a part
! 272: in-part off
! 273:
! 274: : prim-context ( ... p xt -- ... )
! 275: \ execute xt with prim set to p
! 276: prim >r
! 277: swap to prim
! 278: catch
! 279: r> to prim
! 280: throw ;
! 281:
! 282: 1000 constant max-combined
! 283: create combined-prims max-combined cells allot
! 284: variable num-combined
! 285: variable part-num \ current part number during process-combined
! 286:
! 287: : map-combined { xt -- }
! 288: \ perform xt for all components of the current combined instruction
! 289: num-combined @ 0 +do
! 290: combined-prims i th @ xt execute
! 291: loop ;
! 292:
! 293: table constant combinations
! 294: \ the keys are the sequences of pointers to primitives
! 295:
! 296: create current-depth max-stacks cells allot
! 297: create max-depth max-stacks cells allot
! 298: create min-depth max-stacks cells allot
! 299:
! 300: create sp-update-in max-stacks cells allot
! 301: \ where max-depth occured the first time
! 302: create max-depths max-stacks max-combined 1+ * cells allot
! 303: \ maximum depth at start of each part: array[parts] of array[stack]
! 304: create max-back-depths max-stacks max-combined 1+ * cells allot
! 305: \ maximun depth from end of the combination to the start of the each part
! 306:
! 307: : s-c-max-depth ( nstack ncomponent -- addr )
! 308: max-stacks * + cells max-depths + ;
! 309:
! 310: : s-c-max-back-depth ( nstack ncomponent -- addr )
! 311: max-stacks * + cells max-back-depths + ;
! 312:
! 313: wordlist constant primitives
! 314:
! 315: : create-prim ( prim -- )
! 316: dup prim-name 2@ primitives ['] constant insert-wordlist ;
! 317:
! 318: : stack-in ( stack -- addr )
! 319: \ address of number of stack items in effect in
! 320: stack-number @ cells prim prim-stacks-in + ;
! 321:
! 322: : stack-out ( stack -- addr )
! 323: \ address of number of stack items in effect out
! 324: stack-number @ cells prim prim-stacks-out + ;
! 325:
! 326: \ global vars
! 327: variable c-line
! 328: 2variable c-filename
! 329: variable name-line
! 330: 2variable name-filename
! 331: 2variable last-name-filename
! 332: Variable function-number 0 function-number !
! 333: Variable function-old 0 function-old !
! 334: : function-diff ( n -- )
! 335: ." GROUPADD(" function-number @ function-old @ - 0 .r ." )" cr
! 336: function-number @ function-old ! ;
! 337: : forth-fdiff ( -- )
! 338: function-number @ function-old @ - 0 .r ." groupadd" cr
! 339: function-number @ function-old ! ;
! 340:
! 341: \ a few more set ops
! 342:
! 343: : bit-equivalent ( w1 w2 -- w3 )
! 344: xor invert ;
! 345:
! 346: : complement ( set1 -- set2 )
! 347: empty ['] bit-equivalent binary-set-operation ;
! 348:
! 349: \ forward declaration for inst-stream (breaks cycle in definitions)
! 350: defer inst-stream-f ( -- stack )
! 351:
! 352: \ stack access stuff
! 353:
! 354: : normal-stack-access0 { n stack -- }
! 355: n stack stack-access-transform @ execute ." [" 0 .r ." ]" ;
! 356:
! 357: : normal-stack-access1 { n stack -- }
! 358: stack stack-pointer 2@ type
! 359: n if
! 360: n stack normal-stack-access0
! 361: else
! 362: ." TOS"
! 363: endif ;
! 364:
! 365: : normal-stack-access ( n stack -- )
! 366: dup inst-stream-f = if
! 367: ." IMM_ARG(" normal-stack-access1 ." ," immarg ? ." )"
! 368: 1 immarg +!
! 369: else
! 370: normal-stack-access1
! 371: endif ;
! 372:
! 373: : stack-depth { stack -- n }
! 374: current-depth stack stack-number @ th @ ;
! 375:
! 376: : part-stack-access { n stack -- }
! 377: \ print _<stack><x>, x=inst-stream? n : maxdepth-currentdepth-n-1
! 378: ." _" stack stack-pointer 2@ type
! 379: stack stack-number @ { stack# }
! 380: stack stack-depth n + { access-depth }
! 381: stack inst-stream-f = if
! 382: access-depth
! 383: else
! 384: combined prim-stacks-in stack# th @
! 385: assert( dup max-depth stack# th @ = )
! 386: access-depth - 1-
! 387: endif
! 388: 0 .r ;
! 389:
! 390: : part-stack-read { n stack -- }
! 391: stack stack-depth n + ( ndepth )
! 392: stack stack-number @ part-num @ s-c-max-depth @
! 393: \ max-depth stack stack-number @ th @ ( ndepth nmaxdepth )
! 394: over <= if ( ndepth ) \ load from memory
! 395: stack normal-stack-access
! 396: else
! 397: drop n stack part-stack-access
! 398: endif ;
! 399:
! 400: : stack-diff ( stack -- n )
! 401: \ in-out
! 402: dup stack-in @ swap stack-out @ - ;
! 403:
! 404: : part-stack-write { n stack -- }
! 405: stack stack-depth n +
! 406: stack stack-number @ part-num @ s-c-max-back-depth @
! 407: over <= if ( ndepth )
! 408: stack combined ['] stack-diff prim-context -
! 409: stack normal-stack-access
! 410: else
! 411: drop n stack part-stack-access
! 412: endif ;
! 413:
! 414: : stack-read ( n stack -- )
! 415: \ print a stack access at index n of stack
! 416: in-part @ if
! 417: part-stack-read
! 418: else
! 419: normal-stack-access
! 420: endif ;
! 421:
! 422: : stack-write ( n stack -- )
! 423: \ print a stack access at index n of stack
! 424: in-part @ if
! 425: part-stack-write
! 426: else
! 427: normal-stack-access
! 428: endif ;
! 429:
! 430: : item-in-index { item -- n }
! 431: \ n is the index of item (in the in-effect)
! 432: item item-stack @ dup >r stack-in @ ( in-size r:stack )
! 433: item r> stack-in-index-xt @ execute ;
! 434:
! 435: : item-stack-type-name ( item -- addr u )
! 436: item-stack @ stack-type @ type-c-name 2@ ;
! 437:
! 438: : fetch-single ( item -- )
! 439: \ fetch a single stack item from its stack
! 440: >r
! 441: ." vm_" r@ item-stack-type-name type
! 442: ." 2" r@ item-type @ print-type-prefix ." ("
! 443: r@ item-in-index r@ item-stack @ stack-read ." ,"
! 444: r@ item-name 2@ type
! 445: ." );" cr
! 446: rdrop ;
! 447:
! 448: : fetch-double ( item -- )
! 449: \ fetch a double stack item from its stack
! 450: >r
! 451: ." vm_two"
! 452: r@ item-stack-type-name type ." 2"
! 453: r@ item-type @ print-type-prefix ." ("
! 454: r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-read
! 455: ." , " -1 under+ ." (Cell)" stack-read
! 456: ." , " r@ item-name 2@ type
! 457: ." )" cr
! 458: rdrop ;
! 459:
! 460: : same-as-in? ( item -- f )
! 461: \ f is true iff the offset and stack of item is the same as on input
! 462: >r
! 463: r@ item-first @ if
! 464: rdrop false exit
! 465: endif
! 466: r@ item-name 2@ prim prim-items-wordlist @ search-wordlist 0= abort" bug"
! 467: execute @
! 468: dup r@ =
! 469: if \ item first appeared in output
! 470: drop false
! 471: else
! 472: dup item-stack @ r@ item-stack @ =
! 473: swap item-offset @ r@ item-offset @ = and
! 474: endif
! 475: rdrop ;
! 476:
! 477: : item-out-index ( item -- n )
! 478: \ n is the index of item (in the in-effect)
! 479: >r r@ item-stack @ stack-out @ r> item-offset @ - 1- ;
! 480:
! 481: : really-store-single ( item -- )
! 482: >r
! 483: ." vm_"
! 484: r@ item-type @ print-type-prefix ." 2"
! 485: r@ item-stack-type-name type ." ("
! 486: r@ item-name 2@ type ." ,"
! 487: r@ item-out-index r@ item-stack @ stack-write ." );"
! 488: rdrop ;
! 489:
! 490: : store-single ( item -- )
! 491: >r
! 492: store-optimization @ in-part @ 0= and r@ same-as-in? and if
! 493: r@ item-in-index 0= r@ item-out-index 0= xor if
! 494: ." IF_" r@ item-stack @ stack-pointer 2@ type
! 495: ." TOS(" r@ really-store-single ." );" cr
! 496: endif
! 497: else
! 498: r@ really-store-single cr
! 499: endif
! 500: rdrop ;
! 501:
! 502: : store-double ( item -- )
! 503: \ !! store optimization is not performed, because it is not yet needed
! 504: >r
! 505: ." vm_"
! 506: r@ item-type @ print-type-prefix ." 2two"
! 507: r@ item-stack-type-name type ." ("
! 508: r@ item-name 2@ type ." , "
! 509: r@ item-out-index r@ item-stack @ 2dup stack-write
! 510: ." , " -1 under+ stack-write
! 511: ." )" cr
! 512: rdrop ;
! 513:
! 514: : single ( -- xt1 xt2 n )
! 515: ['] fetch-single ['] store-single 1 ;
! 516:
! 517: : double ( -- xt1 xt2 n )
! 518: ['] fetch-double ['] store-double 2 ;
! 519:
! 520: : s, ( addr u -- )
! 521: \ allocate a string
! 522: here swap dup allot move ;
! 523:
! 524: wordlist constant prefixes
! 525:
! 526: : declare ( addr "name" -- )
! 527: \ remember that there is a stack item at addr called name
! 528: create , ;
! 529:
! 530: : !default ( w addr -- )
! 531: dup @ if
! 532: 2drop \ leave nonzero alone
! 533: else
! 534: !
! 535: endif ;
! 536:
! 537: : create-type { addr u xt1 xt2 n stack -- } ( "prefix" -- )
! 538: \ describes a type
! 539: \ addr u specifies the C type name
! 540: \ stack effect entries of the type start with prefix
! 541: create type% %allot >r
! 542: addr u save-mem r@ type-c-name 2!
! 543: xt1 r@ type-fetch !
! 544: xt2 r@ type-store !
! 545: n r@ type-size !
! 546: stack r@ type-stack !
! 547: rdrop ;
! 548:
! 549: : type-prefix ( addr u xt1 xt2 n stack "prefix" -- )
! 550: get-current >r prefixes set-current
! 551: create-type r> set-current
! 552: does> ( item -- )
! 553: \ initialize item
! 554: { item typ }
! 555: typ item item-type !
! 556: typ type-stack @ item item-stack !default
! 557: item item-name 2@ prim prim-items-wordlist @ search-wordlist 0= if
! 558: item item-name 2@ nextname item declare
! 559: item item-first on
! 560: \ typ type-c-name 2@ type space type ." ;" cr
! 561: else
! 562: drop
! 563: item item-first off
! 564: endif ;
! 565:
! 566: : execute-prefix ( item addr1 u1 -- )
! 567: \ execute the word ( item -- ) associated with the longest prefix
! 568: \ of addr1 u1
! 569: 0 swap ?do
! 570: dup i prefixes search-wordlist
! 571: if \ ok, we have the type ( item addr1 xt )
! 572: nip execute
! 573: UNLOOP EXIT
! 574: endif
! 575: -1 s+loop
! 576: \ we did not find a type, abort
! 577: false s" unknown prefix" ?print-error ;
! 578:
! 579: : declaration ( item -- )
! 580: dup item-name 2@ execute-prefix ;
! 581:
! 582: : declaration-list ( addr1 addr2 -- )
! 583: ['] declaration map-items ;
! 584:
! 585: : declarations ( -- )
! 586: wordlist dup prim prim-items-wordlist ! set-current
! 587: prim prim-effect-in prim prim-effect-in-end @ declaration-list
! 588: prim prim-effect-out prim prim-effect-out-end @ declaration-list ;
! 589:
! 590: : print-declaration { item -- }
! 591: item item-first @ if
! 592: item item-type @ type-c-name 2@ type space
! 593: item item-name 2@ type ." ;" cr
! 594: endif ;
! 595:
! 596: : print-declarations ( -- )
! 597: prim prim-effect-in prim prim-effect-in-end @ ['] print-declaration map-items
! 598: prim prim-effect-out prim prim-effect-out-end @ ['] print-declaration map-items ;
! 599:
! 600: : stack-prefix ( stack "prefix" -- )
! 601: get-current >r prefixes set-current
! 602: name tuck nextname create ( stack length ) 2,
! 603: r> set-current
! 604: does> ( item -- )
! 605: 2@ { item stack prefix-length }
! 606: item item-name 2@ prefix-length /string item item-name 2!
! 607: stack item item-stack !
! 608: item declaration ;
! 609:
! 610: \ types pointed to by stacks for use in combined prims
! 611: \ !! output-c-combined shouldn't use these names!
! 612: : stack-type-name ( addr u "name" -- )
! 613: single 0 create-type ;
! 614:
! 615: wordlist constant type-names \ this is here just to meet the requirement
! 616: \ that a type be a word; it is never used for lookup
! 617:
! 618: : stack ( "name" "stack-pointer" "type" -- )
! 619: \ define stack
! 620: name { d: stack-name }
! 621: name { d: stack-pointer }
! 622: name { d: stack-type }
! 623: get-current type-names set-current
! 624: stack-type 2dup nextname stack-type-name
! 625: set-current
! 626: stack-pointer latestxt >body stack-name nextname make-stack ;
! 627:
! 628: stack inst-stream IP Cell
! 629: ' inst-in-index inst-stream stack-in-index-xt !
! 630: ' inst-stream <is> inst-stream-f
! 631: \ !! initialize stack-in and stack-out
! 632:
! 633: \ offset computation
! 634: \ the leftmost (i.e. deepest) item has offset 0
! 635: \ the rightmost item has the highest offset
! 636:
! 637: : compute-offset { item xt -- }
! 638: \ xt specifies in/out; update stack-in/out and set item-offset
! 639: item item-type @ type-size @
! 640: item item-stack @ xt execute dup @ >r +!
! 641: r> item item-offset ! ;
! 642:
! 643: : compute-offset-in ( addr1 addr2 -- )
! 644: ['] stack-in compute-offset ;
! 645:
! 646: : compute-offset-out ( addr1 addr2 -- )
! 647: ['] stack-out compute-offset ;
! 648:
! 649: : compute-offsets ( -- )
! 650: prim prim-stacks-in max-stacks cells erase
! 651: prim prim-stacks-out max-stacks cells erase
! 652: prim prim-effect-in prim prim-effect-in-end @ ['] compute-offset-in map-items
! 653: prim prim-effect-out prim prim-effect-out-end @ ['] compute-offset-out map-items
! 654: inst-stream stack-out @ 0= s" # can only be on the input side" ?print-error ;
! 655:
! 656: : process-simple ( -- )
! 657: prim prim { W^ key } key cell
! 658: combinations ['] constant insert-wordlist
! 659: declarations compute-offsets
! 660: output @ execute ;
! 661:
! 662: : flush-a-tos { stack -- }
! 663: stack stack-out @ 0<> stack stack-in @ 0= and
! 664: if
! 665: ." IF_" stack stack-pointer 2@ 2dup type ." TOS("
! 666: 2dup type 0 stack normal-stack-access0 ." = " type ." TOS);" cr
! 667: endif ;
! 668:
! 669: : flush-tos ( -- )
! 670: ['] flush-a-tos map-stacks1 ;
! 671:
! 672: : fill-a-tos { stack -- }
! 673: stack stack-out @ 0= stack stack-in @ 0<> and
! 674: if
! 675: ." IF_" stack stack-pointer 2@ 2dup type ." TOS("
! 676: 2dup type ." TOS = " type 0 stack normal-stack-access0 ." );" cr
! 677: endif ;
! 678:
! 679: : fill-tos ( -- )
! 680: \ !! inst-stream for prefetching?
! 681: ['] fill-a-tos map-stacks1 ;
! 682:
! 683: : fetch ( addr -- )
! 684: dup item-type @ type-fetch @ execute ;
! 685:
! 686: : fetches ( -- )
! 687: prim prim-effect-in prim prim-effect-in-end @ ['] fetch map-items ;
! 688:
! 689: : stack-update-transform ( n1 stack -- n2 )
! 690: \ n2 is the number by which the stack pointer should be
! 691: \ incremented to pop n1 items
! 692: stack-access-transform @ dup >r execute
! 693: 0 r> execute - ;
! 694:
! 695: : stack-pointer-update { stack -- }
! 696: \ stacks grow downwards
! 697: stack stack-diff
! 698: ?dup-if \ this check is not necessary, gcc would do this for us
! 699: stack inst-stream = if
! 700: ." INC_IP(" 0 .r ." );" cr
! 701: else
! 702: stack stack-pointer 2@ type ." += "
! 703: stack stack-update-transform 0 .r ." ;" cr
! 704: endif
! 705: endif ;
! 706:
! 707: : stack-pointer-updates ( -- )
! 708: ['] stack-pointer-update map-stacks ;
! 709:
! 710: : store ( item -- )
! 711: \ f is true if the item should be stored
! 712: \ f is false if the store is probably not necessary
! 713: dup item-type @ type-store @ execute ;
! 714:
! 715: : stores ( -- )
! 716: prim prim-effect-out prim prim-effect-out-end @ ['] store map-items ;
! 717:
! 718: : print-debug-arg { item -- }
! 719: ." fputs(" quote space item item-name 2@ type ." =" quote ." , vm_out); "
! 720: ." printarg_" item item-type @ print-type-prefix
! 721: ." (" item item-name 2@ type ." );" cr ;
! 722:
! 723: : print-debug-args ( -- )
! 724: ." #ifdef VM_DEBUG" cr
! 725: ." if (vm_debug) {" cr
! 726: prim prim-effect-in prim prim-effect-in-end @ ['] print-debug-arg map-items
! 727: \ ." fputc('\n', vm_out);" cr
! 728: ." }" cr
! 729: ." #endif" cr ;
! 730:
! 731: : print-debug-result { item -- }
! 732: item item-first @ if
! 733: item print-debug-arg
! 734: endif ;
! 735:
! 736: : print-debug-results ( -- )
! 737: cr
! 738: ." #ifdef VM_DEBUG" cr
! 739: ." if (vm_debug) {" cr
! 740: ." fputs(" quote ." -- " quote ." , vm_out); "
! 741: prim prim-effect-out prim prim-effect-out-end @ ['] print-debug-result map-items
! 742: ." fputc('\n', vm_out);" cr
! 743: ." }" cr
! 744: ." #endif" cr ;
! 745:
! 746: : output-super-end ( -- )
! 747: prim prim-c-code 2@ s" SET_IP" search if
! 748: ." SUPER_END;" cr
! 749: endif
! 750: 2drop ;
! 751:
! 752: : output-nextp2 ( -- )
! 753: ." NEXT_P2;" cr ;
! 754:
! 755: variable tail-nextp2 \ xt to execute for printing NEXT_P2 in INST_TAIL
! 756: ' output-nextp2 tail-nextp2 !
! 757:
! 758: : output-label2 ( -- )
! 759: ." LABEL2(" prim prim-c-name 2@ type ." )" cr
! 760: ." NEXT_P2;" cr ;
! 761:
! 762: : output-c-tail1 { xt -- }
! 763: \ the final part of the generated C code, with xt printing LABEL2 or not.
! 764: output-super-end
! 765: print-debug-results
! 766: ." NEXT_P1;" cr
! 767: stores
! 768: fill-tos
! 769: xt execute ;
! 770:
! 771: : output-c-tail1-no-stores { xt -- }
! 772: \ the final part of the generated C code for combinations
! 773: output-super-end
! 774: ." NEXT_P1;" cr
! 775: fill-tos
! 776: xt execute ;
! 777:
! 778: : output-c-tail ( -- )
! 779: tail-nextp2 @ output-c-tail1 ;
! 780:
! 781: : output-c-tail2 ( -- )
! 782: ['] output-label2 output-c-tail1 ;
! 783:
! 784: : output-c-tail-no-stores ( -- )
! 785: tail-nextp2 @ output-c-tail1-no-stores ;
! 786:
! 787: : output-c-tail2-no-stores ( -- )
! 788: ['] output-label2 output-c-tail1-no-stores ;
! 789:
! 790: : type-c-code ( c-addr u xt -- )
! 791: \ like TYPE, but replaces "INST_TAIL;" with tail code produced by xt
! 792: { xt }
! 793: ." {" cr
! 794: ." #line " c-line @ . quote c-filename 2@ type quote cr
! 795: begin ( c-addr1 u1 )
! 796: 2dup s" INST_TAIL;" search
! 797: while ( c-addr1 u1 c-addr3 u3 )
! 798: 2dup 2>r drop nip over - type
! 799: xt execute
! 800: 2r> 10 /string
! 801: \ !! resync #line missing
! 802: repeat
! 803: 2drop type
! 804: ." #line " out-nls @ 2 + . quote out-filename 2@ type quote cr
! 805: ." }" cr ;
! 806:
! 807: : print-entry ( -- )
! 808: ." LABEL(" prim prim-c-name 2@ type ." )" ;
! 809:
! 810: : output-c ( -- )
! 811: print-entry ." /* " prim prim-name 2@ type ." ( " prim prim-stack-string 2@ type ." ) */" cr
! 812: ." /* " prim prim-doc 2@ type ." */" cr
! 813: ." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging
! 814: ." {" cr
! 815: ." DEF_CA" cr
! 816: print-declarations
! 817: ." NEXT_P0;" cr
! 818: flush-tos
! 819: fetches
! 820: print-debug-args
! 821: stack-pointer-updates
! 822: prim prim-c-code 2@ ['] output-c-tail type-c-code
! 823: output-c-tail2
! 824: ." }" cr
! 825: cr
! 826: ;
! 827:
! 828: : disasm-arg { item -- }
! 829: item item-stack @ inst-stream = if
! 830: ." {" cr
! 831: item print-declaration
! 832: item fetch
! 833: item print-debug-arg
! 834: ." }" cr
! 835: endif ;
! 836:
! 837: : disasm-args ( -- )
! 838: prim prim-effect-in prim prim-effect-in-end @ ['] disasm-arg map-items ;
! 839:
! 840: : output-disasm ( -- )
! 841: \ generate code for disassembling VM instructions
! 842: ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr
! 843: ." fputs(" quote prim prim-name 2@ type quote ." , vm_out);" cr
! 844: disasm-args
! 845: ." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr
! 846: ." goto _endif_;" cr
! 847: ." }" cr ;
! 848:
! 849: : output-profile ( -- )
! 850: \ generate code for postprocessing the VM block profile stuff
! 851: ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr
! 852: ." add_inst(b, " quote prim prim-name 2@ type quote ." );" cr
! 853: ." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr
! 854: prim prim-c-code 2@ s" SET_IP" search nip nip
! 855: prim prim-c-code 2@ s" SUPER_END" search nip nip or if
! 856: ." return;" cr
! 857: else
! 858: ." goto _endif_;" cr
! 859: endif
! 860: ." }" cr ;
! 861:
! 862: : output-profile-part ( p )
! 863: ." add_inst(b, " quote
! 864: prim-name 2@ type
! 865: quote ." );" cr ;
! 866:
! 867: : output-profile-combined ( -- )
! 868: \ generate code for postprocessing the VM block profile stuff
! 869: ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr
! 870: ['] output-profile-part map-combined
! 871: ." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr
! 872: combined-prims num-combined @ 1- th @ prim-c-code 2@ s" SET_IP" search nip nip
! 873: combined-prims num-combined @ 1- th @ prim-c-code 2@ s" SUPER_END" search nip nip or if
! 874: ." return;" cr
! 875: else
! 876: ." goto _endif_;" cr
! 877: endif
! 878: ." }" cr ;
! 879:
! 880: : output-superend ( -- )
! 881: \ output flag specifying whether the current word ends a dynamic superinst
! 882: prim prim-c-code 2@ s" SET_IP" search nip nip
! 883: prim prim-c-code 2@ s" SUPER_END" search nip nip or 0<>
! 884: prim prim-c-code 2@ s" SUPER_CONTINUE" search nip nip 0= and
! 885: negate 0 .r ." , /* " prim prim-name 2@ type ." */" cr ;
! 886:
! 887: : gen-arg-parm { item -- }
! 888: item item-stack @ inst-stream = if
! 889: ." , " item item-type @ type-c-name 2@ type space
! 890: item item-name 2@ type
! 891: endif ;
! 892:
! 893: : gen-args-parm ( -- )
! 894: prim prim-effect-in prim prim-effect-in-end @ ['] gen-arg-parm map-items ;
! 895:
! 896: : gen-arg-gen { item -- }
! 897: item item-stack @ inst-stream = if
! 898: ." genarg_" item item-type @ print-type-prefix
! 899: ." (ctp, " item item-name 2@ type ." );" cr
! 900: endif ;
! 901:
! 902: : gen-args-gen ( -- )
! 903: prim prim-effect-in prim prim-effect-in-end @ ['] gen-arg-gen map-items ;
! 904:
! 905: : output-gen ( -- )
! 906: \ generate C code for generating VM instructions
! 907: ." void gen_" prim prim-c-name 2@ type ." (Inst **ctp" gen-args-parm ." )" cr
! 908: ." {" cr
! 909: ." gen_inst(ctp, vm_prim[" function-number @ 0 .r ." ]);" cr
! 910: gen-args-gen
! 911: ." }" cr ;
! 912:
! 913: : stack-used? { stack -- f }
! 914: stack stack-in @ stack stack-out @ or 0<> ;
! 915:
! 916: : output-funclabel ( -- )
! 917: ." &I_" prim prim-c-name 2@ type ." ," cr ;
! 918:
! 919: : output-forthname ( -- )
! 920: '" emit prim prim-name 2@ type '" emit ." ," cr ;
! 921:
! 922: \ : output-c-func ( -- )
! 923: \ \ used for word libraries
! 924: \ ." Cell * I_" prim prim-c-name 2@ type ." (Cell *SP, Cell **FP) /* " prim prim-name 2@ type
! 925: \ ." ( " prim prim-stack-string 2@ type ." ) */" cr
! 926: \ ." /* " prim prim-doc 2@ type ." */" cr
! 927: \ ." NAME(" quote prim prim-name 2@ type quote ." )" cr
! 928: \ \ debugging
! 929: \ ." {" cr
! 930: \ print-declarations
! 931: \ \ !! don't know what to do about that
! 932: \ inst-stream stack-used? IF ." Cell *ip=IP;" cr THEN
! 933: \ data-stack stack-used? IF ." Cell *sp=SP;" cr THEN
! 934: \ fp-stack stack-used? IF ." Cell *fp=*FP;" cr THEN
! 935: \ return-stack stack-used? IF ." Cell *rp=*RP;" cr THEN
! 936: \ flush-tos
! 937: \ fetches
! 938: \ stack-pointer-updates
! 939: \ fp-stack stack-used? IF ." *FP=fp;" cr THEN
! 940: \ ." {" cr
! 941: \ ." #line " c-line @ . quote c-filename 2@ type quote cr
! 942: \ prim prim-c-code 2@ type
! 943: \ ." }" cr
! 944: \ stores
! 945: \ fill-tos
! 946: \ ." return (sp);" cr
! 947: \ ." }" cr
! 948: \ cr ;
! 949:
! 950: : output-label ( -- )
! 951: ." INST_ADDR(" prim prim-c-name 2@ type ." )," cr ;
! 952:
! 953: : output-alias ( -- )
! 954: ( primitive-number @ . ." alias " ) ." Primitive " prim prim-name 2@ type cr ;
! 955:
! 956: : output-c-prim-num ( -- )
! 957: ." N_" prim prim-c-name 2@ type ." ," cr ;
! 958:
! 959: : output-forth ( -- )
! 960: prim prim-forth-code @ 0=
! 961: IF \ output-alias
! 962: \ this is bad for ec: an alias is compiled if tho word does not exist!
! 963: \ JAW
! 964: ELSE ." : " prim prim-name 2@ type ." ( "
! 965: prim prim-stack-string 2@ type ." )" cr
! 966: prim prim-forth-code 2@ type cr
! 967: THEN ;
! 968:
! 969: : output-tag-file ( -- )
! 970: name-filename 2@ last-name-filename 2@ compare if
! 971: name-filename 2@ last-name-filename 2!
! 972: #ff emit cr
! 973: name-filename 2@ type
! 974: ." ,0" cr
! 975: endif ;
! 976:
! 977: : output-tag ( -- )
! 978: output-tag-file
! 979: prim prim-name 2@ 1+ type
! 980: 127 emit
! 981: space prim prim-name 2@ type space
! 982: 1 emit
! 983: name-line @ 0 .r
! 984: ." ,0" cr ;
! 985:
! 986: : output-vi-tag ( -- )
! 987: name-filename 2@ type #tab emit
! 988: prim prim-name 2@ type #tab emit
! 989: ." /^" prim prim-name 2@ type ." *(/" cr ;
! 990:
! 991: [IFDEF] documentation
! 992: : register-doc ( -- )
! 993: prim prim-name 2@ documentation ['] create insert-wordlist
! 994: prim prim-name 2@ 2,
! 995: prim prim-stack-string 2@ condition-stack-effect 2,
! 996: prim prim-wordset 2@ 2,
! 997: prim prim-c-name 2@ condition-pronounciation 2,
! 998: prim prim-doc 2@ 2, ;
! 999: [THEN]
! 1000:
! 1001:
! 1002: \ combining instructions
! 1003:
! 1004: \ The input should look like this:
! 1005:
! 1006: \ lit_+ = lit +
! 1007:
! 1008: \ The output should look like this:
! 1009:
! 1010: \ I_lit_+:
! 1011: \ {
! 1012: \ DEF_CA
! 1013: \ Cell _x_ip0;
! 1014: \ Cell _x_sp0;
! 1015: \ Cell _x_sp1;
! 1016: \ NEXT_P0;
! 1017: \ _x_ip0 = (Cell) IPTOS;
! 1018: \ _x_sp0 = (Cell) spTOS;
! 1019: \ INC_IP(1);
! 1020: \ /* sp += 0; */
! 1021: \ /* lit ( #w -- w ) */
! 1022: \ /* */
! 1023: \ NAME("lit")
! 1024: \ {
! 1025: \ Cell w;
! 1026: \ w = (Cell) _x_ip0;
! 1027: \ #ifdef VM_DEBUG
! 1028: \ if (vm_debug) {
! 1029: \ fputs(" w=", vm_out); printarg_w (w);
! 1030: \ fputc('\n', vm_out);
! 1031: \ }
! 1032: \ #endif
! 1033: \ {
! 1034: \ #line 136 "./prim"
! 1035: \ }
! 1036: \ _x_sp1 = (Cell)w;
! 1037: \ }
! 1038: \ I_plus: /* + ( n1 n2 -- n ) */
! 1039: \ /* */
! 1040: \ NAME("+")
! 1041: \ {
! 1042: \ DEF_CA
! 1043: \ Cell n1;
! 1044: \ Cell n2;
! 1045: \ Cell n;
! 1046: \ NEXT_P0;
! 1047: \ n1 = (Cell) _x_sp0;
! 1048: \ n2 = (Cell) _x_sp1;
! 1049: \ #ifdef VM_DEBUG
! 1050: \ if (vm_debug) {
! 1051: \ fputs(" n1=", vm_out); printarg_n (n1);
! 1052: \ fputs(" n2=", vm_out); printarg_n (n2);
! 1053: \ fputc('\n', vm_out);
! 1054: \ }
! 1055: \ #endif
! 1056: \ {
! 1057: \ #line 516 "./prim"
! 1058: \ n = n1+n2;
! 1059: \ }
! 1060: \ _x_sp0 = (Cell)n;
! 1061: \ }
! 1062: \ NEXT_P1;
! 1063: \ spTOS = (Cell)_x_sp0;
! 1064: \ NEXT_P2;
! 1065:
! 1066: : init-combined ( -- )
! 1067: prim to combined
! 1068: 0 num-combined !
! 1069: current-depth max-stacks cells erase
! 1070: include-skipped-insts @ current-depth 0 th !
! 1071: max-depth max-stacks cells erase
! 1072: min-depth max-stacks cells erase
! 1073: prim prim-effect-in prim prim-effect-in-end !
! 1074: prim prim-effect-out prim prim-effect-out-end ! ;
! 1075:
! 1076: : max! ( n addr -- )
! 1077: tuck @ max swap ! ;
! 1078:
! 1079: : min! ( n addr -- )
! 1080: tuck @ min swap ! ;
! 1081:
! 1082: : inst-stream-adjustment ( nstack -- n )
! 1083: \ number of stack items to add for each part
! 1084: 0= include-skipped-insts @ and negate ;
! 1085:
! 1086: : add-depths { p -- }
! 1087: \ combine stack effect of p with *-depths
! 1088: max-stacks 0 ?do
! 1089: current-depth i th @
! 1090: p prim-stacks-in i th @ + i inst-stream-adjustment +
! 1091: dup max-depth i th max!
! 1092: p prim-stacks-out i th @ -
! 1093: dup min-depth i th min!
! 1094: current-depth i th !
! 1095: loop ;
! 1096:
! 1097: : copy-maxdepths ( n -- )
! 1098: max-depth max-depths rot max-stacks * th max-stacks cells move ;
! 1099:
! 1100: : add-prim ( addr u -- )
! 1101: \ add primitive given by "addr u" to combined-prims
! 1102: primitives search-wordlist s" unknown primitive" ?print-error
! 1103: execute { p }
! 1104: p combined-prims num-combined @ th !
! 1105: num-combined @ copy-maxdepths
! 1106: 1 num-combined +!
! 1107: p add-depths
! 1108: num-combined @ copy-maxdepths ;
! 1109:
! 1110: : compute-effects { q -- }
! 1111: \ compute the stack effects of q from the depths
! 1112: max-stacks 0 ?do
! 1113: max-depth i th @ dup
! 1114: q prim-stacks-in i th !
! 1115: current-depth i th @ -
! 1116: q prim-stacks-out i th !
! 1117: loop ;
! 1118:
! 1119: : make-effect-items { stack# items effect-endp -- }
! 1120: \ effect-endp points to a pointer to the end of the current item-array
! 1121: \ and has to be updated
! 1122: stacks stack# th @ { stack }
! 1123: items 0 +do
! 1124: effect-endp @ { item }
! 1125: i 0 <# #s stack stack-pointer 2@ holds [char] _ hold #> save-mem
! 1126: item item-name 2!
! 1127: stack item item-stack !
! 1128: stack stack-type @ item item-type !
! 1129: i item item-offset !
! 1130: item item-first on
! 1131: item% %size effect-endp +!
! 1132: loop ;
! 1133:
! 1134: : init-effects { q -- }
! 1135: \ initialize effects field for FETCHES and STORES
! 1136: max-stacks 0 ?do
! 1137: i q prim-stacks-in i th @ q prim-effect-in-end make-effect-items
! 1138: i q prim-stacks-out i th @ q prim-effect-out-end make-effect-items
! 1139: loop ;
! 1140:
! 1141: : compute-stack-max-back-depths ( stack -- )
! 1142: stack-number @ { stack# }
! 1143: current-depth stack# th @ dup
! 1144: dup stack# num-combined @ s-c-max-back-depth !
! 1145: -1 num-combined @ 1- -do ( max-depth current-depth )
! 1146: combined-prims i th @ { p }
! 1147: p prim-stacks-out stack# th @ +
! 1148: dup >r max r>
! 1149: over stack# i s-c-max-back-depth !
! 1150: p prim-stacks-in stack# th @ -
! 1151: stack# inst-stream-adjustment -
! 1152: 1 -loop
! 1153: assert( dup stack# inst-stream-adjustment negate = )
! 1154: assert( over max-depth stack# th @ = )
! 1155: 2drop ;
! 1156:
! 1157: : compute-max-back-depths ( -- )
! 1158: \ compute max-back-depths.
! 1159: \ assumes that current-depths is correct for the end of the combination
! 1160: ['] compute-stack-max-back-depths map-stacks ;
! 1161:
! 1162: : process-combined ( -- )
! 1163: combined combined-prims num-combined @ cells
! 1164: combinations ['] constant insert-wordlist
! 1165: combined-prims num-combined @ 1- th ( last-part )
! 1166: @ prim-c-code 2@ prim prim-c-code 2! \ used by output-super-end
! 1167: prim compute-effects
! 1168: prim init-effects
! 1169: compute-max-back-depths
! 1170: output-combined perform ;
! 1171:
! 1172: \ C output
! 1173:
! 1174: : print-item { n stack -- }
! 1175: \ print nth stack item name
! 1176: stack stack-type @ type-c-name 2@ type space
! 1177: ." MAYBE_UNUSED _" stack stack-pointer 2@ type n 0 .r ;
! 1178:
! 1179: : print-declarations-combined ( -- )
! 1180: max-stacks 0 ?do
! 1181: max-depth i th @ min-depth i th @ - 0 +do
! 1182: i stacks j th @ print-item ." ;" cr
! 1183: loop
! 1184: loop ;
! 1185:
! 1186: : part-fetches ( -- )
! 1187: fetches ;
! 1188:
! 1189: : part-output-c-tail ( -- )
! 1190: print-debug-results
! 1191: stores ;
! 1192:
! 1193: : output-combined-tail ( -- )
! 1194: part-output-c-tail
! 1195: in-part @ >r in-part off
! 1196: combined ['] output-c-tail-no-stores prim-context
! 1197: r> in-part ! ;
! 1198:
! 1199: : part-stack-pointer-updates ( -- )
! 1200: next-stack-number @ 0 +do
! 1201: i part-num @ 1+ s-c-max-depth @ dup
! 1202: i num-combined @ s-c-max-depth @ = \ final depth
! 1203: swap i part-num @ s-c-max-depth @ <> \ just reached now
! 1204: part-num @ 0= \ first part
! 1205: or and if
! 1206: stacks i th @ stack-pointer-update
! 1207: endif
! 1208: loop ;
! 1209:
! 1210: : output-part ( p -- )
! 1211: to prim
! 1212: ." /* " prim prim-name 2@ type ." ( " prim prim-stack-string 2@ type ." ) */" cr
! 1213: ." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging
! 1214: ." {" cr
! 1215: print-declarations
! 1216: part-fetches
! 1217: print-debug-args
! 1218: combined ['] part-stack-pointer-updates prim-context
! 1219: 1 part-num +!
! 1220: prim add-depths \ !! right place?
! 1221: prim prim-c-code 2@ ['] output-combined-tail type-c-code
! 1222: part-output-c-tail
! 1223: ." }" cr ;
! 1224:
! 1225: : output-parts ( -- )
! 1226: prim >r in-part on
! 1227: current-depth max-stacks cells erase
! 1228: 0 part-num !
! 1229: ['] output-part map-combined
! 1230: in-part off
! 1231: r> to prim ;
! 1232:
! 1233: : output-c-combined ( -- )
! 1234: print-entry cr
! 1235: \ debugging messages just in parts
! 1236: ." {" cr
! 1237: ." DEF_CA" cr
! 1238: print-declarations-combined
! 1239: ." NEXT_P0;" cr
! 1240: flush-tos
! 1241: \ fetches \ now in parts
! 1242: \ print-debug-args
! 1243: \ stack-pointer-updates now in parts
! 1244: output-parts
! 1245: output-c-tail2-no-stores
! 1246: ." }" cr
! 1247: cr ;
! 1248:
! 1249: : output-forth-combined ( -- )
! 1250: ;
! 1251:
! 1252:
! 1253: \ peephole optimization rules
! 1254:
! 1255: \ data for a simple peephole optimizer that always tries to combine
! 1256: \ the currently compiled instruction with the last one.
! 1257:
! 1258: \ in order for this to work as intended, shorter combinations for each
! 1259: \ length must be present, and the longer combinations must follow
! 1260: \ shorter ones (this restriction may go away in the future).
! 1261:
! 1262: : output-peephole ( -- )
! 1263: combined-prims num-combined @ 1- cells combinations search-wordlist
! 1264: s" the prefix for this superinstruction must be defined earlier" ?print-error
! 1265: ." {"
! 1266: execute prim-num @ 5 .r ." ,"
! 1267: combined-prims num-combined @ 1- th @ prim-num @ 5 .r ." ,"
! 1268: combined prim-num @ 5 .r ." }, /* "
! 1269: combined prim-c-name 2@ type ." */"
! 1270: cr ;
! 1271:
! 1272:
! 1273: \ cost and superinstruction data for a sophisticated combiner (e.g.,
! 1274: \ shortest path)
! 1275:
! 1276: \ This is intended as initializer for a structure like this
! 1277:
! 1278: \ struct cost {
! 1279: \ int loads; /* number of stack loads */
! 1280: \ int stores; /* number of stack stores */
! 1281: \ int updates; /* number of stack pointer updates */
! 1282: \ int offset; /* offset into super2 table */
! 1283: \ int length; /* number of components */
! 1284: \ };
! 1285:
! 1286: \ How do you know which primitive or combined instruction this
! 1287: \ structure refers to? By the order of cost structures, as in most
! 1288: \ other cases.
! 1289:
! 1290: : super2-length ( -- n )
! 1291: combined if
! 1292: num-combined @
! 1293: else
! 1294: 1
! 1295: endif ;
! 1296:
! 1297: : compute-costs { p -- nloads nstores nupdates }
! 1298: \ compute the number of loads, stores, and stack pointer updates
! 1299: \ of a primitive or combined instruction; does not take TOS
! 1300: \ caching into account
! 1301: 0 max-stacks 0 +do
! 1302: p prim-stacks-in i th @ +
! 1303: loop
! 1304: super2-length 1- - \ don't count instruction fetches of subsumed insts
! 1305: 0 max-stacks 0 +do
! 1306: p prim-stacks-out i th @ +
! 1307: loop
! 1308: 0 max-stacks 1 +do \ don't count ip updates, therefore "1 +do"
! 1309: p prim-stacks-in i th @ p prim-stacks-out i th @ <> -
! 1310: loop ;
! 1311:
! 1312: : output-num-part ( p -- )
! 1313: ." N_" prim-c-name 2@ type ." ," ;
! 1314: \ prim-num @ 4 .r ." ," ;
! 1315:
! 1316: : output-name-comment ( -- )
! 1317: ." /* " prim prim-name 2@ type ." */" ;
! 1318:
! 1319: variable offset-super2 0 offset-super2 ! \ offset into the super2 table
! 1320:
! 1321: : output-costs-gforth-simple ( -- )
! 1322: ." {" prim compute-costs
! 1323: rot 2 .r ." ," swap 2 .r ." ," 2 .r ." , "
! 1324: prim output-num-part
! 1325: 1 2 .r ." },"
! 1326: output-name-comment
! 1327: cr ;
! 1328:
! 1329: : output-costs-gforth-combined ( -- )
! 1330: ." {" prim compute-costs
! 1331: rot 2 .r ." ," swap 2 .r ." ," 2 .r ." , "
! 1332: ." N_START_SUPER+" offset-super2 @ 5 .r ." ,"
! 1333: super2-length dup 2 .r ." }," offset-super2 +!
! 1334: output-name-comment
! 1335: cr ;
! 1336:
! 1337: : output-costs ( -- )
! 1338: \ description of superinstructions and simple instructions
! 1339: ." {" prim compute-costs
! 1340: rot 2 .r ." ," swap 2 .r ." ," 2 .r ." ,"
! 1341: offset-super2 @ 5 .r ." ,"
! 1342: super2-length dup 2 .r ." }," offset-super2 +!
! 1343: output-name-comment
! 1344: cr ;
! 1345:
! 1346: : output-super2 ( -- )
! 1347: \ table of superinstructions without requirement for existing prefixes
! 1348: combined if
! 1349: ['] output-num-part map-combined
! 1350: else
! 1351: prim output-num-part
! 1352: endif
! 1353: output-name-comment
! 1354: cr ;
! 1355:
! 1356: \ the parser
! 1357:
! 1358: eof-char max-member \ the whole character set + EOF
! 1359:
! 1360: : getinput ( -- n )
! 1361: rawinput @ endrawinput @ =
! 1362: if
! 1363: eof-char
! 1364: else
! 1365: cookedinput @ c@
! 1366: endif ;
! 1367:
! 1368: :noname ( n -- )
! 1369: dup bl > if
! 1370: emit space
! 1371: else
! 1372: .
! 1373: endif ;
! 1374: print-token !
! 1375:
! 1376: : testchar? ( set -- f )
! 1377: getinput member? ;
! 1378: ' testchar? test-vector !
! 1379:
! 1380: : checksynclines ( -- )
! 1381: \ when input points to a newline, check if the next line is a
! 1382: \ sync line. If it is, perform the appropriate actions.
! 1383: rawinput @ begin >r
! 1384: s" #line " r@ over compare if
! 1385: rdrop 1 line +! EXIT
! 1386: endif
! 1387: 0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr )
! 1388: dup c@ bl = if
! 1389: char+ dup c@ [char] " <> 0= s" sync line syntax" ?print-error
! 1390: char+ dup 100 [char] " scan drop swap 2dup - save-mem filename 2!
! 1391: char+
! 1392: endif
! 1393: dup c@ nl-char <> 0= s" sync line syntax" ?print-error
! 1394: skipsynclines @ if
! 1395: char+ dup rawinput !
! 1396: rawinput @ c@ cookedinput @ c!
! 1397: endif
! 1398: again ;
! 1399:
! 1400: : ?nextchar ( f -- )
! 1401: s" syntax error, wrong char" ?print-error
! 1402: rawinput @ endrawinput @ <> if
! 1403: rawinput @ c@
! 1404: 1 chars rawinput +!
! 1405: 1 chars cookedinput +!
! 1406: nl-char = if
! 1407: checksynclines
! 1408: rawinput @ line-start !
! 1409: endif
! 1410: rawinput @ c@
! 1411: cookedinput @ c!
! 1412: endif ;
! 1413:
! 1414: : charclass ( set "name" -- )
! 1415: ['] ?nextchar terminal ;
! 1416:
! 1417: : .. ( c1 c2 -- set )
! 1418: ( creates a set that includes the characters c, c1<=c<=c2 )
! 1419: empty copy-set
! 1420: swap 1+ rot do
! 1421: i over add-member
! 1422: loop ;
! 1423:
! 1424: : ` ( -- terminal ) ( use: ` c )
! 1425: ( creates anonymous terminal for the character c )
! 1426: char singleton ['] ?nextchar make-terminal ;
! 1427:
! 1428: char a char z .. char A char Z .. union char _ singleton union charclass letter
! 1429: char 0 char 9 .. charclass digit
! 1430: bl singleton tab-char over add-member charclass white
! 1431: nl-char singleton eof-char over add-member complement charclass nonl
! 1432: nl-char singleton eof-char over add-member
! 1433: char : over add-member complement charclass nocolonnl
! 1434: nl-char singleton eof-char over add-member
! 1435: char } over add-member complement charclass nobracenl
! 1436: bl 1+ maxchar .. char \ singleton complement intersection
! 1437: charclass nowhitebq
! 1438: bl 1+ maxchar .. charclass nowhite
! 1439: char " singleton eof-char over add-member complement charclass noquote
! 1440: nl-char singleton charclass nl
! 1441: eof-char singleton charclass eof
! 1442: nl-char singleton eof-char over add-member charclass nleof
! 1443:
! 1444: (( letter (( letter || digit )) **
! 1445: )) <- c-ident ( -- )
! 1446:
! 1447: (( ` # ?? (( letter || digit || ` : )) ++
! 1448: )) <- stack-ident ( -- )
! 1449:
! 1450: (( nowhitebq nowhite ** ))
! 1451: <- forth-ident ( -- )
! 1452:
! 1453: Variable forth-flag
! 1454: Variable c-flag
! 1455:
! 1456: (( (( ` e || ` E )) {{ start }} nonl **
! 1457: {{ end evaluate }}
! 1458: )) <- eval-comment ( ... -- ... )
! 1459:
! 1460: (( (( ` f || ` F )) {{ start }} nonl **
! 1461: {{ end forth-flag @ IF type cr ELSE 2drop THEN }}
! 1462: )) <- forth-comment ( -- )
! 1463:
! 1464: (( (( ` c || ` C )) {{ start }} nonl **
! 1465: {{ end c-flag @ IF type cr ELSE 2drop THEN }}
! 1466: )) <- c-comment ( -- )
! 1467:
! 1468: (( ` - nonl ** {{
! 1469: forth-flag @ IF forth-fdiff ." [ELSE]" cr THEN
! 1470: c-flag @ IF
! 1471: function-diff
! 1472: ." #else /* " function-number @ 0 .r ." */" cr THEN }}
! 1473: )) <- else-comment
! 1474:
! 1475: (( ` + {{ start }} nonl ** {{ end
! 1476: dup
! 1477: IF c-flag @
! 1478: IF
! 1479: function-diff
! 1480: ." #ifdef HAS_" bounds ?DO I c@ toupper emit LOOP cr
! 1481: THEN
! 1482: forth-flag @
! 1483: IF forth-fdiff ." has? " type ." [IF]" cr THEN
! 1484: ELSE 2drop
! 1485: c-flag @ IF
! 1486: function-diff ." #endif" cr THEN
! 1487: forth-flag @ IF forth-fdiff ." [THEN]" cr THEN
! 1488: THEN }}
! 1489: )) <- if-comment
! 1490:
! 1491: (( (( ` g || ` G )) {{ start }} nonl **
! 1492: {{ end
! 1493: forth-flag @ IF forth-fdiff ." group " type cr THEN
! 1494: c-flag @ IF function-diff
! 1495: ." GROUP(" type ." , " function-number @ 0 .r ." )" cr THEN }}
! 1496: )) <- group-comment
! 1497:
! 1498: (( (( eval-comment || forth-comment || c-comment || else-comment || if-comment || group-comment )) ?? nonl ** )) <- comment-body
! 1499:
! 1500: (( ` \ comment-body nleof )) <- comment ( -- )
! 1501:
! 1502: (( {{ start }} stack-ident {{ end 2 pick init-item item% %size + }} white ** )) **
! 1503: <- stack-items
! 1504:
! 1505: (( {{ prim prim-effect-in }} stack-items {{ prim prim-effect-in-end ! }}
! 1506: ` - ` - white **
! 1507: {{ prim prim-effect-out }} stack-items {{ prim prim-effect-out-end ! }}
! 1508: )) <- stack-effect ( -- )
! 1509:
! 1510: (( {{ prim create-prim }}
! 1511: ` ( white ** {{ start }} stack-effect {{ end prim prim-stack-string 2! }} ` ) white **
! 1512: (( {{ start }} forth-ident {{ end prim prim-wordset 2! }} white **
! 1513: (( {{ start }} c-ident {{ end prim prim-c-name 2! }} )) ??
! 1514: )) ?? nleof
! 1515: (( ` " ` " {{ start }} (( noquote ++ ` " )) ++ {{ end 1- prim prim-doc 2! }} ` " white ** nleof )) ??
! 1516: {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }}
! 1517: (( (( ` { nonl ** nleof (( (( nobracenl {{ line @ drop }} nonl ** )) ?? nleof )) ** ` } white ** nleof white ** ))
! 1518: || (( nocolonnl nonl ** nleof white ** )) ** ))
! 1519: {{ end prim prim-c-code 2! skipsynclines on }}
! 1520: (( ` : white ** nleof
! 1521: {{ start }} (( nonl ++ nleof white ** )) ++ {{ end prim prim-forth-code 2! }}
! 1522: )) ?? {{ process-simple }}
! 1523: nleof
! 1524: )) <- simple-primitive ( -- )
! 1525:
! 1526: (( {{ init-combined }}
! 1527: ` = white ** (( {{ start }} forth-ident {{ end add-prim }} white ** )) ++
! 1528: nleof {{ process-combined }}
! 1529: )) <- combined-primitive
! 1530:
! 1531: (( {{ make-prim to prim 0 to combined
! 1532: line @ name-line ! filename 2@ name-filename 2!
! 1533: function-number @ prim prim-num !
! 1534: start }} [ifdef] vmgen c-ident [else] forth-ident [then] {{ end
! 1535: 2dup prim prim-name 2! prim prim-c-name 2! }} white **
! 1536: (( ` / white ** {{ start }} c-ident {{ end prim prim-c-name 2! }} white ** )) ??
! 1537: (( simple-primitive || combined-primitive ))
! 1538: {{ 1 function-number +! }}
! 1539: )) <- primitive ( -- )
! 1540:
! 1541: (( (( comment || primitive || nl white ** )) ** eof ))
! 1542: parser primitives2something
! 1543: warnings @ [IF]
! 1544: .( parser generated ok ) cr
! 1545: [THEN]
! 1546:
! 1547:
! 1548: \ run with gforth-0.5.0 (slurp-file is missing)
! 1549: [IFUNDEF] slurp-file
! 1550: : slurp-file ( c-addr1 u1 -- c-addr2 u2 )
! 1551: \ c-addr1 u1 is the filename, c-addr2 u2 is the file's contents
! 1552: r/o bin open-file throw >r
! 1553: r@ file-size throw abort" file too large"
! 1554: dup allocate throw swap
! 1555: 2dup r@ read-file throw over <> abort" could not read whole file"
! 1556: r> close-file throw ;
! 1557: [THEN]
! 1558:
! 1559: : primfilter ( addr u -- )
! 1560: \ process the string at addr u
! 1561: over dup rawinput ! dup line-start ! cookedinput !
! 1562: + endrawinput !
! 1563: checksynclines
! 1564: primitives2something ;
! 1565:
! 1566: : unixify ( c-addr u1 -- c-addr u2 )
! 1567: \ delete crs from the string
! 1568: bounds tuck tuck ?do ( c-addr1 )
! 1569: i c@ dup #cr <> if
! 1570: over c! char+
! 1571: else
! 1572: drop
! 1573: endif
! 1574: loop
! 1575: over - ;
! 1576:
! 1577: : process-file ( addr u xt-simple x-combined -- )
! 1578: output-combined ! output !
! 1579: save-mem 2dup filename 2!
! 1580: slurp-file unixify
! 1581: warnings @ if
! 1582: ." ------------ CUT HERE -------------" cr endif
! 1583: primfilter ;
! 1584:
! 1585: \ : process ( xt -- )
! 1586: \ bl word count rot
! 1587: \ process-file ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to prims2x0.6.2.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth