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