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