1: ;;$Id: primitives2c.el,v 1.2 1994/05/03 19:10:35 pazsan Exp $
2: ;;Copyright 1992 by the ANSI figForth Development Group
3:
4: ;; To Do:
5: ;; rewrite in Forth (using regexp)
6: ;; cleanup wrt. float vs. cell and load vs. store
7:
8: ;Optimizations:
9: ;superfluous stores are removed. GCC removes the superfluous loads by itself
10: ;TOS and FTOS can be kept in register( variable)s.
11: ;
12: ;Problems:
13: ;The TOS optimization is somewhat hairy. The problems by example:
14: ;1) dup ( w -- w w ): w=TOS; sp-=1; sp[1]=w; TOS=w;
15: ; The store is not superfluous although the earlier opt. would think so
16: ; Alternatively: sp[0]=TOS; w=TOS; sp-=1; TOS=w;
17: ;2) ( -- .. ): sp[0] = TOS; ... /* This additional store is necessary */
18: ;3) ( .. -- ): ... TOS = sp[0]; /* as well as this load */
19: ;4) ( -- ): /* but here they are unnecessary */
20: ;5) Words that call NEXT themselves have to be done very carefully.
21:
22: (setq max-lisp-eval-depth 1000)
23:
24: (defun filter-primitives (source destination filter)
25: "convert source into destination using filter"
26: (switch-to-buffer (generate-new-buffer destination))
27: (insert-file source)
28: (insert (format "/* File generated by $RCSfile: primitives2c.el,v $ (%s) from %s */\n" filter source))
29: (filter-primitives1 filter)
30: (write-file destination))
31:
32: (defun match-string (N)
33: "Returns the string of the Nth match"
34: (let ((b (match-beginning N))
35: (e (match-end N)))
36: (cond (b (buffer-substring b e))
37: (t ""))))
38:
39: (defun filter-primitives1 (filter)
40: "replace primitives in the rest of the buffer with filtered primitives"
41: (cond ((re-search-forward "^\\([^ \t\n]+\\)\t+\\([^\t\n]*--[^\t\n]*\\)\t+\\([^\t\n]+\\)\t*\\([^ \t\n]+\\)?\n\\(\"\"[^\"]*\"\"\n\\)?\\(\\([^:\n].*\n\\)*\\)\\(:\n\\(\\(.+\n\\)*\\)\\)?$" nil t)
42: ;\\(:\n\\(\\(.+\n\\)*\\)\\)?
43: (replace-match
44: (funcall filter
45: (match-string 1)
46: (match-string 2)
47: (match-string 3)
48: (cond ((equal (match-string 4) "") (match-string 1))
49: (t (match-string 4)))
50: (match-string 5)
51: (match-string 7)
52: (match-string 9)
53: ))
54: (filter-primitives1 filter))))
55:
56: (defun list-filter (forth-name stack-effect standards c-name doku code forth-code)
57: (format "&&I_%s," c-name))
58:
59: (defvar primitive-number 0)
60:
61: (defun alias-filter (forth-name stack-effect standards c-name doku code forth-code)
62: (setq primitive-number (+ 1 primitive-number))
63: (format "%s Alias %s" (- -5 primitive-number) forth-name))
64:
65: (defun c-filter (forth-name stack-effect standards c-name doku code forth-code)
66: "c code for the primitive"
67: (let ((effects (parse-stack-effect stack-effect)))
68: (format "I_%s: /* %s ( %s ) */\n/* %s */\n{\nLabel ca;\n%s\nNAME(\"%s\")\n{\n%s}\nNEXT_P1;\n%sNEXT1_P2;\n}\n"
69: c-name forth-name stack-effect doku
70: (prefix effects) forth-name code (suffix effects))))
71:
72: (defun forth-filter (forth-name stack-effect standards c-name doku code forth-code)
73: "forth equivalent for the primitive"
74: ;should other info be included?
75: (cond ((equal forth-code "") "")
76: (t (format ": %s ( %s )\n%s" forth-name stack-effect forth-code))))
77:
78: (defun prefix (effects)
79: "c-code for declaring vars and getting them from the stack"
80: (format "%s%s%ssp += %s;\nfp += %s;\n"
81: (declarations (unique (append (effect-in effects) (effect-out effects))))
82: (store-tos effects)
83: (loads (effect-in effects))
84: (effect-cells effects)
85: (effect-floats effects)))
86:
87: (defun suffix (effects)
88: "c code for storing vars to the stack"
89: (format "%s%s"
90: (stores (effect-out effects) effects)
91: (load-tos effects)))
92:
93: (defun unique (set)
94: "the set with duplicates removed"
95: (cond ((null set) nil)
96: ((memq (car set) (cdr set)) (unique (cdr set)))
97: (t (cons (car set) (unique (cdr set))))))
98:
99: (defun cells (vars)
100: "the number of stack cells needed by vars"
101: (cond ((null vars) 0)
102: (t (+ (cond ((float-type (car vars)) 0)
103: ((double-type (car vars)) 2)
104: (t 1))
105: (cells (cdr vars))))))
106:
107: (defun floats (vars)
108: "the number of floating-point stack items needed by vars"
109: (cond ((null vars) 0)
110: (t (+ (cond ((float-type (car vars)) 1)
111: (t 0))
112: (floats (cdr vars))))))
113:
114: (defun declarations (vars)
115: "C declarations for vars"
116: (mapconcat '(lambda (var) (format "%s %s;\n" (type var) var)) vars ""))
117:
118: (defun regexp-assoc (var ralist)
119: (cond ((null ralist) (error "%s does not match" var))
120: ((string-match (caar ralist) var) (cadar ralist))
121: (t (regexp-assoc var (cdr ralist)))))
122:
123:
124: (defun type (var)
125: "a declaration for var"
126: (let ((data (match-data)))
127: (unwind-protect
128: (regexp-assoc (format "%s" var)
129: '(("^a_" "Cell *")
130: ("^c_" "Char *")
131: ("^df_" "DFloat *")
132: ("^sf_" "SFloat *")
133: ("^f_" "Float *")
134: ("^xt" Xt)
135: ("^wid" Wid)
136: ("^f83name" "F83Name *")
137: ("^ud" UDCell)
138: ("^r" Float)
139: ("^f" Bool)
140: ("^c" Char)
141: ("^[nw]" Cell)
142: ("^u" UCell)
143: ("^d" DCell)))
144: (store-match-data data))))
145:
146: (defun double-type (var)
147: (memq (type var) '(UDCell DCell)))
148:
149: (defun float-type (var)
150: (equal (type var) 'Float))
151:
152: (defun loads (vars)
153: "C code for loading vars from the stack"
154: (cond ((null vars) "")
155: ((double-type (car vars)) (format "{Double_Store _d; _d.cells.low = %s; _d.cells.high = %s; %s = _d.dcell;}\n%s"
156: (stack (+ 1 (cells (cdr vars))))
157: (stack (cells (cdr vars)))
158: (car vars)
159: (loads (cdr vars))))
160: ((float-type (car vars)) (format "%s = %s;\n%s"
161: (car vars)
162: (fstack (floats (cdr vars)))
163: (loads (cdr vars))))
164: (t (format "%s = (%s) %s;\n%s"
165: (car vars)
166: (type (car vars))
167: (stack (cells (cdr vars)))
168: (loads (cdr vars))))))
169:
170: (defun stores (vars effects)
171: "C code for storing vars on the stack"
172: (cond ((null vars) "")
173: ((redundantq vars effects) (format "/* store redundant */\n%s"
174: (stores (cdr vars) effects)))
175: ((double-type (car vars)) (format "{Double_Store _d; _d.dcell = %s; %s = _d.cells.low; %s = _d.cells.high;}\n%s"
176: (car vars)
177: (stack (+ 1 (cells (cdr vars))))
178: (stack (cells (cdr vars)))
179: (stores (cdr vars) effects)))
180: ((float-type (car vars)) (format "%s = %s;\n%s"
181: (fstack (floats (cdr vars)))
182: (car vars)
183: (stores (cdr vars) effects)))
184: (t (format "%s = (Cell)%s ;\n%s"
185: (stack (cells (cdr vars)))
186: (car vars)
187: (stores (cdr vars) effects)))))
188:
189: (defun redundantq (vars effects)
190: "Is the store of (car vars) redundant?"
191: (let ((in-vars (memq (car vars) (effect-in effects))))
192: (and in-vars
193: (cond ((float-type (car vars)) (= (effect-floats effects)
194: (- (floats in-vars) (floats vars))))
195: (t (= (effect-cells effects)
196: (- (cells in-vars) (cells vars))))))))
197:
198: (defun load-tos (effects)
199: "TOS-loading code, if necessary"
200: (format "%s%s"
201: (cond ((and (= 0 (cells (effect-out effects)))
202: (< 0 (cells (effect-in effects))))
203: "IF_TOS(TOS = sp[0]);\n")
204: (t ""))
205: (cond ((and (= 0 (floats (effect-out effects)))
206: (< 0 (floats (effect-in effects))))
207: "IF_FTOS(FTOS = fp[0]);\n")
208: (t ""))))
209:
210: (defun store-tos (effects)
211: "TOS-storing code, if necessary"
212: (format "%s%s"
213: (cond ((or (redundant-tos effects)
214: (and (= 0 (cells (effect-in effects)))
215: (< 0 (cells (effect-out effects)))))
216: "IF_TOS(sp[0] = TOS);\n")
217: (t ""))
218: (cond ((or (redundant-ftos effects)
219: (and (= 0 (floats (effect-in effects)))
220: (< 0 (floats (effect-out effects)))))
221: "IF_FTOS(fp[0] = FTOS);\n")
222: (t ""))))
223:
224: (defun redundant-tos (effects)
225: "Does redundantq consider storing into the original TOS location redundant?"
226: (red-tos1 (effect-out effects) effects))
227:
228: (defun red-tos1 (vars effects)
229: (cond ((null vars) nil)
230: ((and (not (float-type (car vars)))
231: (redundantq vars effects))
232: (or (= (- (effect-cells effects))
233: (cells (cdr vars)))
234: (red-tos1 (cdr vars) effects)))))
235:
236: (defun redundant-ftos (effects)
237: "Does redundantq consider storing into the original FTOS location redundant?"
238: (red-ftos1 (effect-out effects) effects))
239:
240: (defun red-ftos1 (vars effects)
241: (cond ((null vars) nil)
242: ((and (float-type (car vars))
243: (redundantq vars effects))
244: (or (= (- (effect-floats effects))
245: (floats (cdr vars)))
246: (red-ftos1 (cdr vars) effects)))))
247:
248: (defun stack (n)
249: "the stack entry at depth n"
250: (cond ((= n 0) "TOS")
251: (t (format "sp[%d]" n))))
252:
253: (defun fstack (n)
254: "the float stack entry at depth n"
255: (cond ((= n 0) "FTOS")
256: (t (format "fp[%d]" n))))
257:
258: (defun parse-stack-effect (stack-effect)
259: "lists of items before and after --"
260: (let ((effect-list (read (format "(%s)" stack-effect))))
261: (let ((in (stack-before effect-list))
262: (out (stack-after effect-list)))
263: (list in
264: out
265: (- (cells in) (cells out))
266: (- (floats in) (floats out))))))
267:
268: (defun effect-in (effects)
269: (car effects))
270:
271: (defun effect-out (effects)
272: (cadr effects))
273:
274: (defun effect-cells (effects)
275: "the number of input - output cells"
276: (cadr (cdr effects)))
277:
278: (defun effect-floats (effects)
279: (cadr (cddr effects)))
280:
281: (defun stack-before (effect-list)
282: (cond ((equal (car effect-list) '--) nil)
283: (t (cons (car effect-list) (stack-before (cdr effect-list))))))
284:
285: (defun stack-after (effect-list)
286: (cdr (memq '-- effect-list)))
287:
288: (defun cadr (list)
289: (car (cdr list)))
290:
291: (defun caar (list)
292: (car (car list)))
293:
294: (defun cddr (list)
295: (cdr (cdr list)))
296:
297: (defun cadar (list)
298: (car (cdr (car list))))
299:
300: (defun make-c ()
301: (filter-primitives "primitives.b" "primitives.i" 'c-filter))
302:
303: (defun make-list ()
304: (filter-primitives "primitives.b" "prim_labels.i" 'list-filter))
305:
306: (defun make-alias ()
307: (filter-primitives "primitives.b" "prim_alias.4th" 'alias-filter))
308:
309: (defun make-forth ()
310: (filter-primitives "primitives.b" "primitives.4th" 'forth-filter))
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to primitives2c.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth