Annotation of gforth/primitives2c.el, revision 1.1

1.1     ! anton       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))

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>