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