fth/flkopt.fs

   1 \  FLK level 2 optimizer
   2 \
   3 \  Copyright (C) 1998 Lars Krueger
   4 \
   5 \  This file is part of FLK.
   6 \
   7 \  FLK is free software; you can redistribute it and/or
   8 \  modify it under the terms of the GNU General Public License
   9 \  as published by the Free Software Foundation; either version 2
  10 \  of the License, or (at your option) any later version.
  11 \
  12 \  This program is distributed in the hope that it will be useful,
  13 \  but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 \  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 \  GNU General Public License for more details.
  16 \
  17 \  You should have received a copy of the GNU General Public License
  18 \  along with this program; if not, write to the Free Software
  19 \  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20
  21 \ $Id: flkopt.fs,v 1.8 1998/09/13 18:55:51 root Exp $
  22 \ $Log: flkopt.fs,v $
  23 \ Revision 1.8  1998/09/13 18:55:51  root
  24 \ fixed optimizers for cf stack
  25 \
  26 \ Revision 1.7  1998/08/30 10:50:59  root
  27 \ new optimizing algorithm
  28 \
  29 \ Revision 1.6  1998/07/18 10:49:59  root
  30 \ bug corrected
  31 \
  32 \ Revision 1.5  1998/07/16 19:31:37  root
  33 \ changed to conditional near jumps
  34 \
  35 \ Revision 1.4  1998/07/13 18:08:54  root
  36 \ various optimizations
  37 \
  38 \ Revision 1.3  1998/07/06 18:01:13  root
  39 \ new optimizers ( IF/WHILE)
  40 \
  41 \ Revision 1.2  1998/07/05 18:45:25  root
  42 \ bugs corrected, added X forms routines, .faulty-word added
  43 \
  44 \ Revision 1.1  1998/07/03 20:57:50  root
  45 \ Initial revision
  46 \
  47
  48 : (_sizing)         ( prim-xt -- )
  49   0 opt-getlit        \ pxt x rel?
  50   SWAP ROT EXECUTE SWAP
  51   0 opt-setlit
  52   1 1 opt-remove ;
  53
  54 opt( ''# '' CELLS )opt: ['] CELLS (_sizing) ;opt
  55 opt( ''# '' 1+    )opt: ['] 1+    (_sizing) ;opt
  56 opt( ''# '' 1-    )opt: ['] 1-    (_sizing) ;opt
  57 opt( ''# '' CHAR+ )opt: ['] 1+    (_sizing) ;opt
  58 opt( ''# '' 2*    )opt: ['] 2*    (_sizing) ;opt
  59 opt( ''# '' 2/    )opt: ['] 2/    (_sizing) ;opt
  60
  61 \ General arithmetic optimizer. Precalculates or produces faster code.
  62 : (#arith)        ( xt -- )
  63   0 opt-getlit        \ xt x rel?
  64   0 2 opt-remove
  65   regalloc-reset
  66   req-any
  67   ?+relocate
  68   ## tos0 EXECUTE ;
  69
  70 : (##arith)         ( xt -- )
  71    1 opt-getlit
  72    0 opt-getlit       \ xt x1 rel1 x0 rel0
  73    ROT OR -ROT        \ xt rel tos1 tos0
  74    TURN EXECUTE SWAP      \ x rel
  75    0 opt-setlit
  76    1 2 opt-remove ;
  77
  78 opt( ''# '' +   )opt: ['] add, (#arith) ;opt
  79 opt( ''# '' -   )opt: ['] sub, (#arith) ;opt
  80 opt( ''# '' OR  )opt: ['] or,  (#arith) ;opt
  81 opt( ''# '' AND )opt: ['] and, (#arith) ;opt
  82 opt( ''# '' XOR )opt: ['] xor, (#arith) ;opt
  83
  84 opt( ''# ''# '' +   )opt: ['] +   (##arith) ;opt
  85 opt( ''# ''# '' -   )opt: ['] -   (##arith) ;opt
  86 opt( ''# ''# '' OR  )opt: ['] OR  (##arith) ;opt
  87 opt( ''# ''# '' AND )opt: ['] AND (##arith) ;opt
  88 opt( ''# ''# '' XOR )opt: ['] XOR (##arith) ;opt
  89
  90 \ @ optimizer.
  91 opt( ''# '' @ )opt:
  92    0 opt-getlit DROP      \ addr
  93    0 2 opt-remove
  94    regalloc-reset
  95    req-free
  96    #[] free0 mov,
  97    0 free>tos ;opt
  98
  99 \ ! optimizer.
 100 opt( ''# '' ! )opt:
 101    0 opt-getlit DROP      \ addr
 102    0 2 opt-remove
 103    regalloc-reset
 104    req-any
 105    tos0 #[] mov,
 106    1 reg-free ;opt
 107
 108 \ +! optimizer.
 109 opt( ''# '' +! )opt:
 110    0 opt-getlit DROP      \ addr
 111    0 2 opt-remove
 112    regalloc-reset
 113    req-any
 114    tos0 #[] add,
 115    1 reg-free ;opt
 116
 117 \ Optimizer of + @ sequence.
 118 opt( ''# '' + '' @ )opt:
 119     0 opt-getlit      \ x rel?
 120     regalloc-reset
 121     req-any         \ tos0=offs
 122     ?+relocate
 123     [tos0] tos0 mov,
 124     0 3 opt-remove
 125     ;opt
 126
 127 opt( '' + '' @ )opt:
 128     regalloc-reset
 129     req-any         \ tos0=offs
 130     req-any         \ tos1=addr
 131     0 [tos0+tos1] tos1 mov,
 132     1 reg-free
 133     0 2 opt-remove
 134     ;opt
 135
 136 opt( '' 0= '' IF )opt:
 137   regalloc-reset
 138   req-any
 139   tos0 tos0 test,
 140   1 reg-free
 141   ['] n-jnz, (ahead)
 142   0 2 opt-remove
 143 ;opt
 144
 145 : (#-rel-IF)        ( jmp-xt n-free -- orig )
 146   0 opt-getlit        \ xt nf x rel?
 147   regalloc-reset
 148   req-any
 149   ?+relocate ## tos0 cmp,
 150   reg-free
 151   (ahead)
 152   0 3 opt-remove
 153 ;
 154
 155 : (rel-IF)        ( jmp-xt nfree -- orig )
 156   regalloc-reset
 157   req-any req-any
 158   tos0 tos1 cmp,
 159   1+ reg-free
 160   (ahead)
 161   0 2 opt-remove
 162 ;
 163
 164 opt( '' =  '' IF )opt: ['] n-jnz,  1 (rel-IF) ;opt
 165 opt( '' <> '' IF )opt: ['] n-jz,   1 (rel-IF) ;opt
 166 opt( '' <  '' IF )opt: ['] n-jnl,  1 (rel-IF) ;opt
 167 opt( '' >  '' IF )opt: ['] n-jng,  1 (rel-IF) ;opt
 168 opt( '' <= '' IF )opt: ['] n-jnle, 1 (rel-IF) ;opt
 169 opt( '' >= '' IF )opt: ['] n-jnge, 1 (rel-IF) ;opt
 170
 171 opt( ''# '' =  '' IF )opt: ['] n-jnz,  1 (#-rel-IF) ;opt
 172 opt( ''# '' <> '' IF )opt: ['] n-jz,   1 (#-rel-IF) ;opt
 173 opt( ''# '' <  '' IF )opt: ['] n-jnl,  1 (#-rel-IF) ;opt
 174 opt( ''# '' >  '' IF )opt: ['] n-jng,  1 (#-rel-IF) ;opt
 175 opt( ''# '' <= '' IF )opt: ['] n-jnle, 1 (#-rel-IF) ;opt
 176 opt( ''# '' >= '' IF )opt: ['] n-jnge, 1 (#-rel-IF) ;opt
 177
 178 opt( '' OVER '' =  '' IF )opt: ['] n-jnz,  0 (rel-IF) 0 1 opt-remove ;opt
 179 opt( '' OVER '' <> '' IF )opt: ['] n-jz,   0 (rel-IF) 0 1 opt-remove ;opt
 180 opt( '' OVER '' <  '' IF )opt: ['] n-jng,  0 (rel-IF) 0 1 opt-remove ;opt
 181 opt( '' OVER '' >  '' IF )opt: ['] n-jnl,  0 (rel-IF) 0 1 opt-remove ;opt
 182 opt( '' OVER '' <= '' IF )opt: ['] n-jnge, 0 (rel-IF) 0 1 opt-remove ;opt
 183 opt( '' OVER '' >= '' IF )opt: ['] n-jnle, 0 (rel-IF) 0 1 opt-remove ;opt
 184
 185 opt( ''# '' OVER '' =  '' IF )opt: ['] n-jnz,  0 (#-rel-IF) 0 1 opt-remove ;opt
 186 opt( ''# '' OVER '' <> '' IF )opt: ['] n-jz,   0 (#-rel-IF) 0 1 opt-remove ;opt
 187 opt( ''# '' OVER '' <  '' IF )opt: ['] n-jng,  0 (#-rel-IF) 0 1 opt-remove ;opt
 188 opt( ''# '' OVER '' >  '' IF )opt: ['] n-jnl,  0 (#-rel-IF) 0 1 opt-remove ;opt
 189 opt( ''# '' OVER '' <= '' IF )opt: ['] n-jnge, 0 (#-rel-IF) 0 1 opt-remove ;opt
 190 opt( ''# '' OVER '' >= '' IF )opt: ['] n-jnle, 0 (#-rel-IF) 0 1 opt-remove ;opt
 191
 192 opt( '' DUP '' >R )opt:
 193   regalloc-reset
 194   req-any
 195   tos0 push,
 196   0 2 opt-remove
 197 ;opt
 198
 199 opt( '' R> '' DROP )opt:
 200   regalloc-reset
 201   req-free
 202   free0 pop,
 203   0 2 opt-remove
 204 ;opt
 205
 206 opt( '' DROP '' R> )opt:
 207   regalloc-reset
 208   req-any
 209   tos0 pop,
 210   0 2 opt-remove
 211 ;opt
 212
 213 : (2DUP-rel-IF)       ( jmp-xt -- )
 214   regalloc-reset
 215   req-any
 216   req-any
 217   tos0 tos1 cmp,      \ jxt
 218   (ahead)
 219   0 3 opt-remove
 220 ;
 221
 222 opt( '' 2DUP '' =  '' IF )opt: ['] n-jnz,  (2DUP-rel-IF) ;opt
 223 opt( '' 2DUP '' <> '' IF )opt: ['] n-jz,   (2DUP-rel-IF) ;opt
 224 opt( '' 2DUP '' <  '' IF )opt: ['] n-jnl,  (2DUP-rel-IF) ;opt
 225 opt( '' 2DUP '' >  '' IF )opt: ['] n-jng,  (2DUP-rel-IF) ;opt
 226 opt( '' 2DUP '' <= '' IF )opt: ['] n-jnle, (2DUP-rel-IF) ;opt
 227 opt( '' 2DUP '' >= '' IF )opt: ['] n-jnge, (2DUP-rel-IF) ;opt
 228
 229 : (rel-WHILE)         ( dest jmp-xt nr-free -- orig dest)
 230   (rel-IF)        \ dest orig
 231   1 (CS-ROLL) ;
 232
 233 opt( '' =  '' WHILE )opt: ['] n-jnz,  1 (rel-WHILE) ;opt
 234 opt( '' <> '' WHILE )opt: ['] n-jz,   1 (rel-WHILE) ;opt
 235 opt( '' <  '' WHILE )opt: ['] n-jnl,  1 (rel-WHILE) ;opt
 236 opt( '' >  '' WHILE )opt: ['] n-jng,  1 (rel-WHILE) ;opt
 237 opt( '' <= '' WHILE )opt: ['] n-jnle, 1 (rel-WHILE) ;opt
 238 opt( '' >= '' WHILE )opt: ['] n-jnge, 1 (rel-WHILE) ;opt
 239
 240 opt( '' OVER '' =  '' WHILE )opt: ['] n-jnz,  0 (rel-WHILE) 0 1 opt-remove ;opt
 241 opt( '' OVER '' <> '' WHILE )opt: ['] n-jz,   0 (rel-WHILE) 0 1 opt-remove ;opt
 242 opt( '' OVER '' <  '' WHILE )opt: ['] n-jng,  0 (rel-WHILE) 0 1 opt-remove ;opt
 243 opt( '' OVER '' >  '' WHILE )opt: ['] n-jnl,  0 (rel-WHILE) 0 1 opt-remove ;opt
 244 opt( '' OVER '' <= '' WHILE )opt: ['] n-jnge, 0 (rel-WHILE) 0 1 opt-remove ;opt
 245 opt( '' OVER '' >= '' WHILE )opt: ['] n-jnle, 0 (rel-WHILE) 0 1 opt-remove ;opt
 246
 247 : (2DUP-rel-WHILE)      ( dest jmp-xt nr-free -- orig dest )
 248   (2DUP-rel-IF) 1 (CS-ROLL) ;
 249
 250 opt( '' 2DUP '' =  '' WHILE )opt: ['] n-jnz,  (2DUP-rel-WHILE) ;opt
 251 opt( '' 2DUP '' <> '' WHILE )opt: ['] n-jz,   (2DUP-rel-WHILE) ;opt
 252 opt( '' 2DUP '' <  '' WHILE )opt: ['] n-jnl,  (2DUP-rel-WHILE) ;opt
 253 opt( '' 2DUP '' >  '' WHILE )opt: ['] n-jng,  (2DUP-rel-WHILE) ;opt
 254 opt( '' 2DUP '' <= '' WHILE )opt: ['] n-jnle, (2DUP-rel-WHILE) ;opt
 255 opt( '' 2DUP '' >= '' WHILE )opt: ['] n-jnge, (2DUP-rel-WHILE) ;opt
 256
 257 opt( '' OVER '' @ )opt:
 258   regalloc-reset
 259   req-any
 260   req-any
 261   req-free
 262   0 [tos1] free0 mov,
 263   0 free>tos
 264   0 2 opt-remove ;opt
 265
 266 opt( '' OVER '' ! )opt:
 267   regalloc-reset
 268   req-any         \ tos0=x
 269   req-any         \ tos1=addr
 270   tos0 0 [tos1] mov,
 271   1 reg-free
 272   0 2 opt-remove
 273 ;opt
 274
 275 opt( '' DUP '' 1- )opt:
 276   regalloc-reset
 277   req-any
 278   req-free
 279   -1 [tos0] free0 lea,
 280   0 free>tos
 281   0 2 opt-remove
 282 ;opt
 283
 284 : (#_log_IF)        ( log-xt -- )
 285   0 opt-getlit        \ xt x rel?
 286   regalloc-reset
 287   req-any
 288   ?+relocate
 289   ## tos0 EXECUTE
 290   1 reg-free
 291   ['] n-jz, (ahead)
 292   0 3 opt-remove
 293   ;
 294
 295 : (_log_IF)         ( log-xt -- )
 296   regalloc-reset      \ xt
 297   req-any
 298   req-any
 299   tos0 tos1 EXECUTE
 300   2 reg-free
 301   ['] n-jz, (ahead)
 302   0 2 opt-remove
 303 ;
 304
 305 opt( '' OR  '' IF )opt: ['] or,   (_log_IF) ;opt
 306 opt( '' AND '' IF )opt: ['] test, (_log_IF) ;opt
 307 opt( ''# '' OR  '' IF )opt: ['] or,   (#_log_IF) ;opt
 308 opt( ''# '' AND '' IF )opt: ['] test, (#_log_IF) ;opt
 309
 310 opt( '' DUP '' CELL+ '' @ )opt:
 311   regalloc-reset
 312   req-any
 313   req-free
 314   4 [tos0] free0 mov,
 315   0 free>tos
 316   0 3 opt-remove
 317 ;opt