Annotation of gforth/primitives2c.el, revision 1.3

1.2       pazsan      1: ;;$Id: primitives2c.el,v 1.8 1993/05/19 13:39:45 anton Exp pazsan $
1.1       anton       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))
1.3     ! pazsan     63:   (format "%s Alias %s" (- -7 primitive-number) forth-name))
1.1       anton      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)))
1.3     ! pazsan     68:     (format "I_%s:     /* %s ( %s ) */\n/* %s */\n{\nDEF_CA\n%s\nNAME(\"%s\")\n{\n%s}\nNEXT_P1;\n%sNEXT1_P2;\n}\n"
1.1       anton      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>