fth/flkhcomp.fs

   1 \  FLK compiler words (host versions)
   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: flkhcomp.fs,v 1.16 1998/09/21 11:25:20 root Exp $
  22 \ $Log: flkhcomp.fs,v $
  23 \ Revision 1.16  1998/09/21 11:25:20  root
  24 \ fixed ?DO
  25 \
  26 \ Revision 1.15  1998/09/13 15:42:04  root
  27 \ introduced separate control flow stack
  28 \
  29 \ Revision 1.14  1998/08/30 10:50:59  root
  30 \ new optimizing algorithm
  31 \
  32 \ Revision 1.13  1998/07/18 10:49:59  root
  33 \ bug corrected
  34 \
  35 \ Revision 1.12  1998/07/16 19:31:37  root
  36 \ changed to conditional near jumps
  37 \
  38 \ Revision 1.11  1998/07/13 18:08:54  root
  39 \ various optimizations
  40 \
  41 \ Revision 1.10  1998/07/03 09:09:28  root
  42 \ support for level 2 optimizer
  43 \
  44 \ Revision 1.9  1998/06/08 22:14:51  root
  45 \ literals cache (preparation to level 2 optimizer)
  46 \
  47 \ Revision 1.8  1998/05/01 18:11:25  root
  48 \ GNU license text added
  49 \ comments checked
  50 \
  51 \ Revision 1.7  1998/04/30 09:42:25  root
  52 \ Comments added.
  53 \
  54 \ Revision 1.6  1998/04/24 16:47:39  root
  55 \ DO LOOP corrected
  56 \
  57 \ Revision 1.5  1998/04/16 18:43:39  root
  58 \ flow control improved
  59 \
  60 \ Revision 1.4  1998/04/16 14:09:25  root
  61 \ IF ELSE THEN generates faster code
  62 \
  63 \ Revision 1.3  1998/04/15 18:15:30  root
  64 \ reordered words
  65 \
  66 \ Revision 1.2  1998/04/09 11:35:03  root
  67 \ all words checked and OK
  68 \
  69 \ Revision 1.1  1998/04/07 20:10:33  root
  70 \ Initial revision
  71 \
  72
  73 META-DEF
  74 \ Factor of AHEAD and IF.
  75 : (ahead)         ( xt -- )
  76   CFT-orig (new-cs-item)
  77   (curr-cf-item) CHAR+
  78   allocator-state
  79   fwd-jmp (curr-cf-item) 3 CELLS + !
  80 ;
  81 OSEM-DEF
  82
  83 \ See standard.
  84 : IF          ( flag -- ) ( C: -- orig )
  85 ( OK )
  86   regalloc-reset
  87   req-any
  88   tos0 tos0 test,
  89   1 reg-free
  90   ['] n-jz, (ahead)
  91   ;
  92
  93 : THEN          ( -- ) ( C: orig -- )
  94 ( OK )
  95   regalloc-reset
  96   CFT-orig (check-cs-item)
  97   FALSE (curr-cf-item) CHAR+
  98   allocator-rebuild
  99   (curr-cf-item) 3 CELLS + @
 100   resolve-jmp
 101   (delete-cs-item)
 102   ;
 103
 104 : ELSE          ( -- ) ( C: orig1 -- orig2 )
 105   regalloc-reset
 106   ['] jmp, (ahead)
 107   1 (CS-ROLL)
 108   [OSEM] THEN [PREVIOUS]
 109   ;
 110
 111 \ See standard.
 112 : BEGIN         ( -- ) ( C: -- dest )
 113 ( OK )
 114   regalloc-reset
 115   CFT-dest (new-cs-item)
 116   (curr-cf-item) CHAR+ allocator-state
 117   asm-here (curr-cf-item) 3 CELLS + !
 118   ;
 119
 120 \ See standard.
 121 : UNTIL         ( flag -- )  ( C: dest -- )
 122 ( OK )
 123   CFT-dest (check-cs-item)
 124   regalloc-reset
 125   req-any
 126   tos0 tos0 test,
 127   1 reg-free
 128   TRUE (curr-cf-item) CHAR+ allocator-rebuild
 129   (curr-cf-item) 3 CELLS + @    \ jmp-addr
 130   0 jnz,
 131   ## jmp,
 132   0 $:
 133   (delete-cs-item)
 134   ;
 135
 136 \ See standard.
 137 : WHILE         ( C: dest -- orig dest ) ( flag -- )
 138 ( OK )
 139   CFT-dest (check-cs-item)
 140   regalloc-reset
 141   req-any
 142   tos0 tos0 test,
 143   1 reg-free
 144   ['] n-jz, (ahead)       \ dest orig
 145   1 (CS-ROLL)
 146   ;
 147
 148 \ See standard.
 149 : REPEAT        ( C: orig dest -- ) ( -- )
 150 ( OK )
 151   CFT-dest (check-cs-item)
 152   regalloc-reset
 153   FALSE (curr-cf-item) CHAR+
 154   allocator-rebuild       \ C: orig dest
 155   (curr-cf-item) 3 CELLS + @    \ jmp-addr / C: orig dest
 156   (delete-cs-item)      \ jmp-addr / C: orig
 157   ## jmp,
 158   CFT-orig (check-cs-item)
 159   (curr-cf-item) CHAR+ allocator-store
 160   (curr-cf-item) 3 CELLS + @
 161   (delete-cs-item)      \ jmp-addr
 162   resolve-jmp
 163   ;
 164
 165 \ Data format for CFT-do
 166 \ Offset  meaning
 167 \ 0   type
 168 \ 1 byte  allocator state
 169 \ 3 cells   a1=addr. of inner code
 170 \ 4 cells   a3=fix-addr for ?DO
 171 \ 5 cells   last-leave
 172
 173 META-DEF
 174 \ Set's up a new cf-stack item and copies the current allocator state to it.
 175 : (prepare-do-cs-item)      ( -- )
 176   CFT-do (new-cs-item)
 177   (curr-cf-item) CHAR+ allocator-state
 178   asm-here (curr-cf-item) 3 CELLS + !
 179 ;
 180 OSEM-DEF
 181
 182 \ See standard.
 183 : DO          ( lim start -- ) ( C: -- do-sys )
 184   regalloc-reset
 185   req-any         \ tos0=start=ind=eax
 186   req-any         \ tos1=lim=ecx
 187   $$ 80000000 ## tos1 add,
 188   tos1 tos0 sub,
 189   tos1 push,
 190   tos0 push,        \ r: lim ind
 191   2 reg-free
 192   (prepare-do-cs-item)
 193   0 (curr-cf-item) 4 CELLS + !
 194   ;
 195
 196 \ See standard.
 197 : ?DO           ( lim start -- ) ( C: -- do-sys )
 198   regalloc-reset
 199   req-any         \ tos0=start=ind=eax
 200   req-any         \ tos1=lim=ecx
 201   tos1 tos0 cmp,
 202   ['] n-je, fwd-jmp       \ a3
 203   $$ 80000000 ## tos1 add,
 204   tos1 tos0 sub,
 205   tos1 push,
 206   tos0 push,        \ a3 / r: cnt ind
 207   2 reg-free
 208   (prepare-do-cs-item)
 209   (curr-cf-item) 4 CELLS + !
 210   ;
 211
 212 \ See standard.
 213 : LOOP        ( -- ) ( C: do-sys -- )
 214 ( OK )
 215   CFT-do (check-cs-item)
 216   regalloc-reset
 217   req-free
 218   free0 pop,
 219   free0 inc,
 220   free0 push,
 221   regalloc-reset
 222   TRUE (curr-cf-item) CHAR+ allocator-rebuild
 223   (curr-cf-item) 3 CELLS + @    \ jmp-addr
 224   ## n-jno,
 225   8 ## esp add,
 226   (curr-cf-item) 4 CELLS + @ ?DUP IF
 227     resolve-jmp
 228   THEN
 229   (delete-cs-item)
 230   ;
 231
 232 : I         ( -- I )
 233 ( OK )
 234   regalloc-reset
 235   req-free
 236   0 [esp] free0 mov,
 237   4 [esp] free0 add,
 238   0 free>tos ;
 239
 240 : UNLOOP        ( -- )
 241 ( OK )
 242   regalloc-reset
 243   8 ## esp add, ;
 244
 245 : J         ( -- J )
 246 ( OK )
 247   regalloc-reset
 248   req-free
 249   8 [esp] free0 mov,
 250   12 [esp] free0 add,
 251   0 free>tos ;
 252
 253 CO-DEF
 254 : S"        ( -<">- )
 255 ( OK )
 256   [CHAR] " PARSE      \ addr len
 257   2>R td-here CODE-SIZE +
 258   (opt-add-r-const) 2R>
 259   TUCK 2>R (opt-add-const)
 260   2R> td-", ;
 261
 262
 263 [FORTH] S" TYPE"
 264 ' CSEM >BODY @ SEARCH-WORDLIST
 265 0= [IF]
 266  S" Can't find TYPE." error-exit
 267 [THEN]
 268 CONSTANT (type-xt)
 269 [PREVIOUS]
 270
 271 : ."        ( -<">- )
 272 ( OK )
 273   [COMMENTS] S" [PREVIOUS]
 274   (type-xt) (opt-add-xt) ;
 275
 276 \ See standard.
 277 : RECURSE         ( -- )
 278 ( OK )
 279   t-lastheader t->CFA t-@ >R
 280   regalloc-reset
 281   (end-word) R>
 282   DWORD ## call,
 283   ;
 284
 285 OSEM-DEF
 286
 287 : CASE          ( -- C: case-sys )
 288   CFT-case (new-cs-item)
 289   0 (curr-cf-item) CELL+ !
 290 ;
 291
 292 : OF            ( case-sys -- orig case-sys / x -- )
 293   CFT-case (check-cs-item)
 294   1 (curr-cf-item) CELL+ +!
 295   [OSEM] OVER =
 296   IF DROP [PREVIOUS]
 297   1 (CS-ROLL)
 298 ;
 299
 300 : ENDOF         ( orig1 case -- orig2 case )
 301   CFT-case (check-cs-item)
 302   1 (CS-ROLL)
 303   [OSEM] ELSE [PREVIOUS]
 304   1 (CS-ROLL)
 305 ;
 306
 307 : ENDCASE         ( orig1..orign case-sys -- )
 308   CFT-case (check-cs-item)
 309   (curr-cf-item) CELL+ @
 310   (delete-cs-item)      \ cnt
 311   [OSEM] DROP [PREVIOUS]
 312   0 ?DO
 313     [OSEM] THEN [PREVIOUS]
 314   LOOP
 315 ;