File:  [gforth] / gforth / prims2x.fs
Revision 1.130: download - view: text, annotated - select for diffs
Thu Jan 30 16:14:31 2003 UTC (21 years, 1 month ago) by anton
Branches: MAIN
CVS tags: HEAD
eliminated some (hopefully outdated) hppa special treatments
rewrote hppa cacheflush
prims2x can now process CRLF inputs (but the output is partly unixified)
prims2x can now process several sync lines in sequence
minor fixes

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

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>