Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.1 | ;;$Id: primitives2c.el,v 1.12 1994/01/31 15:43:38 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{\n%s\nNAME(\"%s\")\n{\n%s}\nNEXT_P1;\n%s}\nNEXT1_P2;\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)) |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |