File:  [gforth] / gforth / Attic / primitives2c.el
Revision 1.3: download - view: text, annotated - select for diffs
Thu May 5 15:46:52 1994 UTC (27 years, 1 month ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Added direct threading for R3/4000. Still needs cache flush.
Added direct threading for R3/4000. Needs still cache flush.

    1: ;;$Id: primitives2c.el,v 1.3 1994/05/05 15:46:52 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" (- -7 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{\nDEF_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>