fth/flktl2.fs

   1 \ FLK level2 optimizers (target)
   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$
  22 \ $Log$
  23
  24 \ This is executed in the host.
  25
  26 : t-COUNT         ( addr -- addr+1 len )
  27   DUP 1+ SWAP t-C@ ;
  28
  29 : t-COMPARE         ( taddr len addr len -- flag )
  30   2SWAP SWAP TARGET + SWAP 2SWAP
  31   COMPARE ;
  32
  33 : t-SEARCH-WORDLIST       ( addr len wid -- {xt} flag )
  34   -ROT          \ wid ca u
  35   2DUP (calcVocHash)      \ wid ca u hash
  36   [ISEM] CELLS [PREVIOUS]     \ wid ca u offs
  37   TURN +        \ ca u &head
  38   BEGIN         \ ca u &head
  39     t-@         \ ca u xt
  40     DUP         \ ca u xt xt
  41     IMAGE-BASE <>
  42   WHILE         \ ca u xt
  43     DUP t->name t-COUNT       \ ca u xt na nl
  44     ROT >R        \ ca u na nl / r: xt
  45     2OVER         \ ca u na nl ca u / r: xt
  46     t-COMPARE 0= IF       \ ca u / r: xt
  47       R>        \ ca u xt
  48       DUP t->flags t-C@     \ ca u xt flags
  49       DUP HF-VISIBLE AND IF     \ ca u xt flags
  50         2SWAP 2DROP       \ xt flags
  51   HF-IMMEDIATE AND
  52   IF 1 ELSE -1 THEN
  53   EXIT
  54       ELSE        \ ca u xt flags
  55         DROP >R
  56       THEN
  57     THEN        \ ca u
  58     R>          \ ca u xt
  59   REPEAT        \ ca u image-base
  60   DROP 2DROP 0 ;
  61
  62
  63 : t-SEARCH-WORDLISTS      ( addr len -- xt true / false )
  64   2DUP HA-DEF-WL t-SEARCH-WORDLIST  \ addr len {xt} flag
  65   IF
  66     NIP NIP TRUE      \ xt true
  67   ELSE
  68     HA-ASS-WL t-SEARCH-WORDLIST   \ {xt} flag
  69   THEN ;
  70
  71 \ Structure of a node:
  72 \ Offset    Meaning
  73 \ 0     next brother
  74 \ 1 cell  xt to optimizer away
  75 \ 2 cells   xt of optimizer
  76 \ 3 cells   next node (downward)
  77
  78 \ Run down the chain stored in node-var and return the node containing xt and
  79 \ true or false if not found.
  80 : (opt-find-brother)      ( xt node-var -- node true / false )
  81   BEGIN
  82     t-@ DUP         \ xt node do?
  83   WHILE         \ xt node
  84     2DUP 1 [ISEM] CELLS [PREVIOUS] +
  85     t-@ =         \ xt node found?
  86     IF          \ xt node
  87       NIP TRUE EXIT
  88     THEN        \ xt node
  89   REPEAT
  90   2DROP FALSE ;
  91
  92 \ Make a node.
  93 : (opt-make-node)       ( lastnode xt -- node )
  94   td-here CODE-SIZE +       \ ln xt' node
  95   ROT DUP         \ xt' node ln ln
  96   t-@ td-r,         \ xt' node ln
  97   OVER SWAP t-!       \ xt' node
  98   SWAP td-r, 0 td-r, 0 td-r,    \ node
  99 ;
 100
 101 S" opt2tree" ' COMMENTS >BODY @   \ addr len wid
 102 SEARCH-WORDLIST       \ xt flg
 103 0= [IF]
 104   S" opt2tree not declared." error-exit
 105 [THEN]
 106 >BODY @         \ t-xt
 107 t->DFA t-@ CONSTANT t-opt2tree
 108
 109 ISEM-DEF
 110 \ A pretty 0.
 111 : opt(        ( -- 0 )
 112   0 ;
 113
 114 \ Placeholder for literal. Use only within opt( )opt:.
 115 : ''#         ( ... n -- .. 0 n+1 )
 116   0 SWAP 1+ ;
 117
 118 \ Find the word in the target dictionary and append the target xt to the list.
 119 : ''        ( ... n -<name>- ... xt n+1 )
 120   BL PARSE      \ ... n addr len
 121   t-SEARCH-WORDLISTS    \ ... n {xt} found?
 122   0= ABORT" Unknown word to optimize away."
 123   SWAP 1+ ;
 124
 125 \ Define an optimizer.
 126 : )opt:         ( ... n -- )
 127   tc-here         \ ... n xt
 128   (begin-word)
 129   TRUE TO (t-compiling)
 130   ALSO CSEM ALSO DEFINITIONS OSEM
 131   (t-interpret)
 132   (end-word) ret,
 133   PREVIOUS PREVIOUS DEFINITIONS
 134   SWAP          \ ... xt n
 135   OVER 0= ABORT" no words to optimize."
 136   t-opt2tree        \ ... xt n lastnode
 137   BEGIN         \ ... xt n lastnode
 138     OVER 2 +          \ ... xt n lastnode n+2
 139     ROLL        \ ... xt n lastnode xt'
 140     2DUP SWAP         \ ... xt n ln xt' xt' ln
 141     (opt-find-brother)      \ ... xt n ln xt' ((node true) /false)
 142     IF          \ ... xt n lastnode xt' node
 143       NIP NIP         \ ... xt n node
 144     ELSE        \ ... xt n ln xt'
 145       (opt-make-node)       \ ... xt n node
 146     THEN        \ ... xt n node
 147     3 [ISEM] CELLS [PREVIOUS] +   \ ... xt n lastnode
 148     SWAP 1- SWAP OVER 0=    \ ... xt n-1 lastnode fini?
 149   UNTIL         \ ... xt 0 lastnode
 150   NIP 1 [ISEM] CELLS [PREVIOUS] -   \ xt opt-addr
 151   DUP t-@         \ xt opt-addr old-xt
 152   ABORT" Trying to define two optimizers for the same sequence."
 153   t-! ;
 154
 155 : (t-opt2tree)        ( ind node-var -- )
 156   BEGIN         \ ind v
 157     t-@ DUP         \ ind node cont?
 158   WHILE         \ ind node
 159     OVER SPACES
 160     DUP 1 [ISEM] CELLS [PREVIOUS] + t-@ \ ind node xt
 161     DUP 0= IF         \ ind node xt
 162       ." -- number -- "
 163       DROP
 164     ELSE        \ ind node xt
 165       DUP
 166       t->name
 167       t-COUNT
 168       SWAP TARGET + SWAP TYPE
 169       SPACE .
 170     THEN          \ ind node
 171     DUP 2 [ISEM] CELLS [PREVIOUS] + t-@ \ ind node opt?
 172     IF ."  ***" THEN CR
 173     2DUP 3 [ISEM] CELLS [PREVIOUS] +  \ ind node ind son-var
 174     SWAP 2 + SWAP RECURSE     \ ind node
 175   REPEAT 2DROP
 176 ;
 177
 178 : t-.opt2tree         ( -- )
 179   CR
 180   ." ##################### tree of optimizers ########################" CR
 181   0 t-opt2tree [ISEM] (t-opt2tree) [PREVIOUS]
 182   ." #################################################################" CR
 183 ;
 184
 185 OSEM-DEF
 186 : ;opt          ( -- )
 187   FALSE TO (t-compiling) ; IMMEDIATE
 188 ISEM-DEF
 189 ISEM DEFINITIONS SEAL