meta/meta-40-tc-compiler-10-word-utils.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Metacompiler
   4 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   5 ;; GPLv3 ONLY
   6 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   7 ;; low-level target compiler words
   8 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9
  10 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  11 ;; addr is NOT rva!
  12 : tc-xcfind-plain  ( addr count voclptr -- rva-cfa true // false )
  13   over 1 tc-max-word-name-length bounds? ifnot drop 2drop false exit endif
  14   begin
  15     tc-@ ?dup
  16   while
  17     ;; ( addr count rva-lfa )
  18       \ >r endcr 2dup type ."  : " r@ tc-lfa->nfa tc-nfa-count swap tc->real swap type space r@ .hex8 cr r>
  19     >r 2dup r@ tc-lfa->nfa
  20     ;; check smudge flag
  21     dup tc-nfa->ffa tc-ffa@ tc-(wflag-smudge) and ifnot
  22       tc-nfa-count swap tc->real swap s=ci if
  23         ;; i found her!
  24         2drop r> tc-lfa->cfa true exit
  25       endif
  26     else
  27       drop 2drop
  28     endif
  29     r>
  30   repeat
  31   2drop false
  32 ;
  33
  34
  35 : tc-xcfind  ( addr count voclptr -- rva-cfa true // false )
  36   forth-hashtable-bits ifnot tc-xcfind-plain exit endif
  37   dup tc-vocid-hashed? ifnot tc-xcfind-plain exit endif
  38   over 1 tc-max-word-name-length bounds? ifnot drop 2drop false exit endif
  39   ;; calculate name hash
  40   >r 2dup tc-str-name-hash-real-addr
  41   ;; ( addr count u32hash | voclptr )
  42   ;; calc bucket address
  43   dup tc-name-hash-fold-mask cells r> tc-vocid->htable +
  44   swap >r
  45   ;; ( addr count bucketaddr | u32hash )
  46   begin
  47     tc-@ ?dup
  48   while
  49     ;; ( addr count rva-bfa | u32hash )
  50     ;; check hash
  51     dup tc-bfa->hfa tc-@ r@ = if
  52       ;; hash is ok, check name
  53       ;; no need to check length separately, because string comparison will do it for us
  54       dup tc-bfa->nfa
  55       ;; ( addr count rva-bfa rva-nfa | u32hash )
  56       2over  ;; ( addr count rva-bfa rva-nfa addr count | u32hash )
  57       rot    ;; ( addr count rva-bfa addr count rva-nfa | u32hash )
  58       tc-nfa-count swap tc->real swap s=ci if
  59         ;; ( addr count rva-bfa | u32hash )
  60         dup tc-bfa->ffa tc-ffa@ tc-(wflag-smudge) and ifnot
  61           ;; ( addr count rva-bfa | u32hash )
  62           tc-bfa->nfa tc-nfa->cfa
  63           nrot 2drop rdrop
  64           true
  65           exit
  66         endif
  67       endif
  68     endif
  69   repeat
  70   ;; ( addr count | u32hash )
  71   2drop rdrop
  72   false
  73 ;
  74
  75
  76 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  77 : (x-tc-find-simple)  ( addr count -- rva-cfa true // false )
  78   tc-current ?dup ifnot 2drop false exit endif
  79   tc-@ >r 2dup r> tc-xcfind if nrot 2drop true exit endif
  80   tc-forth dup tc-current tc-@ = if drop 2drop false exit endif
  81   tc-xcfind
  82 ;
  83
  84 : x-tc-xcfind  ( addr count -- rva-cfa true // false )
  85   2dup (x-tc-find-simple) if nrot 2drop true exit endif
  86   ;; very simple one-level colon resolution
  87   2dup [char] : str-trim-at-char ?dup ifnot
  88     drop 2drop false exit
  89   endif
  90   (x-tc-find-simple) ifnot 2drop false exit endif
  91   dup tc-cfa->ffa tc-ffa@ tc-(wflag-vocab) and ifnot
  92     drop 2drop false
  93   else
  94     tc-voc-cfa->vocid nrot
  95     [char] : str-skip-after-char rot
  96     tc-xcfind
  97   endif
  98 ;
  99
 100 : x-tc-xcfind-must  ( addr count -- rva-cfa )
 101   2dup 2>r x-tc-xcfind ifnot
 102     2r> endcr ." UNKNOWN WORD: \`" type ." \`\n"
 103     abort" unknown target system word"
 104   else
 105     2rdrop
 106   endif
 107 ;
 108
 109
 110 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 111 : (tc-fix-label-name)  ( addr count -- addr count )
 112   ;; check for colon (i should introduce "str-chr" or something! ;-)
 113   tc-current tc-@ tc-forth <> if
 114     2dup [char] : str-trim-at-char nip ifnot
 115       ;; no colon, and not FORTH dictionary, get dict name
 116       tc-current tc-@ tc-vocid->headnfa tc-@
 117       tc-id-count swap tc->real swap pad 256 + c4s:copy-counted
 118       " :" pad 256 + c4s:cat-counted
 119       ;; append word name
 120       pad 256 + c4s:cat-counted
 121       ;; new name at pad
 122       pad 256 + count
 123         \ endcr ." SYNTH NAME:<" 2dup type ." >\n"
 124     endif
 125   endif
 126   ;; remove "forth:" prefix, if there is any
 127   2dup [char] : str-trim-at-char dup if
 128     2dup " FORTH" s=ci if
 129       1+ nip  ;; we'll cut with this
 130       /string
 131         \ endcr 2dup ." ||" type cr
 132     else
 133       2drop
 134     endif
 135   else
 136     2drop
 137   endif
 138 ;
 139
 140
 141 ;; this prepends the name of the current vocabulary if it is not tc-forth
 142 ;; (and if string contains no colon)
 143 : (tc-create-forth-label)  ( addr count value forward -- )
 144   asm-labman:do-fix-label-name? >r
 145   0 to asm-labman:do-fix-label-name?
 146   2swap (tc-fix-label-name) 2swap
 147   asmx86:asm-Make-Forth-Label
 148   r> to asm-labman:do-fix-label-name?
 149 ;
 150
 151 : tc-create-forward-forth-label  ( addr count -- )
 152   dup if 0 true (tc-create-forth-label) else 2drop endif
 153 ;
 154
 155 : (tc-create-forth-label-fixup)  ( addr count -- )
 156   asm-labman:do-fix-label-name? >r
 157   0 to asm-labman:do-fix-label-name?
 158   (tc-fix-label-name)
 159   4 asmx86:LABEL-TYPE-CFA asmx86:asm-Label-Fixup
 160   r> to asm-labman:do-fix-label-name?
 161 ;
 162
 163 : tc-create-forth-label-disp-fixup  ( addr count -- )
 164   dup if
 165     asm-labman:do-fix-label-name? >r
 166     0 to asm-labman:do-fix-label-name?
 167     (tc-fix-label-name)
 168     ;; it should not be different from a normal label, so...
 169     ;; (if it is different, it is a bug)
 170     ( asmx86:LABEL-TYPE-CFA ) asmx86:LABEL-TYPE-NORMAL asmx86:asm-Jmp-Label-Fixup
 171     r> to asm-labman:do-fix-label-name?
 172   else
 173     2drop
 174   endif
 175 ;
 176
 177 : tc-create-forward-forth-label-and-fixup  ( addr count -- )
 178   dup if
 179     2dup tc-create-forward-forth-label
 180     (tc-create-forth-label-fixup)
 181   else
 182     2drop
 183   endif
 184 ;
 185
 186 ;; non-forward
 187 : tc-create-forth-label  ( addr count value -- )
 188   over if false (tc-create-forth-label) else drop 2drop endif
 189 ;
 190
 191
 192 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 193
 194 ;; WARNING! call this ONLY if you're ABSOLUTELY sure that the word is not in the tc system yet!
 195 ;; addr is NOT rva!
 196 : tc-cfa,-(str)-nochecks  ( addr count -- )
 197   tc-create-forward-forth-label-and-fixup
 198   0 tc-,
 199 ;
 200
 201 ;; WARNING! call this ONLY if you're ABSOLUTELY sure that the word is not in the tc system yet!
 202 ;; addr is NOT rva!
 203 : tc-compile,-(str)-nochecks  ( addr count -- )
 204   tc-create-forward-forth-label-and-fixup
 205   0 tc-,
 206 ;
 207
 208 ;; addr is NOT rva!
 209 : tc-compile,-(str)  ( addr count -- )
 210   2dup x-tc-xcfind if
 211     tc-compile,
 212       \ endcr ." KNOWN:<" 2dup type ." >\n"
 213     2drop
 214   else
 215       \ endcr ." *UNKNOWN:<" 2dup type ." >\n"
 216     tc-compile,-(str)-nochecks
 217   endif
 218 ;
 219
 220 ;; addr is NOT rva!
 221 : tc-cfa,-(str-raw)  ( addr count -- )
 222   2dup x-tc-xcfind if
 223     tc-reladdr, 2drop
 224   else
 225     \ FIXME! this WILL break if i'll make "," and "compile," different!
 226     tc-cfa,-(str)-nochecks
 227   endif
 228 ;
 229
 230 ;; addr is NOT rva!
 231 : tc-cfa,-(str)  ( addr count -- )
 232   " LITCFA" tc-compile,-(str)
 233   tc-cfa,-(str-raw)
 234 ;
 235
 236 : tc-compile  ( -- )  \ word
 237   parse-name [compile] sliteral
 238   compile tc-compile,-(str)
 239 ; immediate
 240
 241
 242 0
 243 dup constant tc-rva-doforth cell+
 244 dup constant tc-rva-doconst cell+
 245 dup constant tc-rva-dovar cell+
 246 dup constant tc-rva-dovalue cell+
 247 dup constant tc-rva-dodefer cell+
 248 dup constant tc-rva-dodoes cell+
 249 dup constant tc-rva-dooverride cell+
 250 dup constant tc-rva-douservar cell+
 251 constant tc-rva-do-size
 252
 253 tc-rva-do-size buffer: tc-rva-do-table
 254 tc-rva-do-table tc-rva-do-size erase
 255
 256
 257 : tc-get-do-label-name  ( type -- addr count )
 258   case
 259     tc-rva-doforth of " ur_doforth" endof
 260     tc-rva-doconst of " ur_doconst" endof
 261     tc-rva-dovar of " ur_dovar" endof
 262     tc-rva-dovalue of " ur_dovalue" endof
 263     tc-rva-dodefer of " ur_dodefer" endof
 264     tc-rva-dodoes of " ur_dodoes" endof
 265     tc-rva-dooverride of " ur_dooverride" endof
 266     tc-rva-douservar of " ur_douservar" endof
 267     abort" tc-get-do-label-name: invalid do label type"
 268   endcase
 269 ;
 270
 271 ;; returns false if the label is not defined yet
 272 ;; updates label cache if it is defined
 273 : tc-get-label-addr  ( type -- addr true // false )
 274   dup tc-rva-do-table + @ dup ifnot drop  ;; no cached address yet, check if it is defined
 275     dup tc-get-do-label-name asmx86:asm-Get-Label  dup not-?abort" tc-get-label-addr: wutafuck?"
 276     ;; ( type value 1 // type value -1 )
 277     -if 2drop false else swap tc-rva-do-table + 2dup ! drop true endif
 278   else nip true endif
 279 ;
 280
 281 ;; this puts fixup if necessary
 282 : tc-put-do-label-disp  ( type -- )
 283   dup tc-get-label-addr if  ;; known address
 284     asmx86:asm-PC 4+ - asmx86:asm-, drop
 285   else  ;; unknown address, create fixup
 286     tc-get-do-label-name asmx86:LABEL-TYPE-NORMAL asmx86:asm-Jmp-Label-Fixup
 287     0 asmx86:asm-,
 288   endif
 289 ;
 290
 291
 292 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 293 : (tc-is-cfa-call?)  ( rvacfa dotype -- flag )
 294   tc-get-label-addr ifnot drop false
 295   else over tc-c@ 0xe8 = ifnot 2drop false
 296   else swap 1+ dup tc-@ 4+ + =
 297   endif endif
 298 ;
 299
 300 : tc-is-constant?  ( rvacfa -- flag )  tc-rva-doconst (tc-is-cfa-call?) ;
 301 : tc-is-variable?  ( rvacfa -- flag )  tc-rva-dovar (tc-is-cfa-call?) ;
 302 : tc-is-value?  ( rvacfa -- flag )  tc-rva-dovalue (tc-is-cfa-call?) ;
 303
 304
 305 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 306 : tc-compile-do-call  ( type -- )
 307   tc-check-align-here
 308   0xe8 tc-c, ;; CALL
 309   tc-put-do-label-disp
 310   tc-align-here
 311 ;
 312
 313 : tc-compile-call-cfa  ( rva-cfa -- )
 314   2dup x-tc-xcfind if
 315     tc-(cfa-call,)
 316     \ endcr ." WORD FOUND: <" 2dup type ." >\n"
 317     2drop
 318   else
 319     \ endcr ." FORWARD WORD: <" 2dup type ." >\n"
 320     2dup tc-create-forward-forth-label
 321     tc-(cfa-0call,)
 322     tc-create-forth-label-disp-fixup
 323   endif
 324 ;
 325
 326 : tc-compile-call  ( -- )  \ word
 327   parse-name [compile] sliteral
 328   compile tc-compile-call-cfa
 329 ; immediate
 330
 331
 332 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 333 : tc-GetForthLabel  ( addr count type -- value 1 // value -1 // false )
 334 \ asm-labman:dump-labels
 335   asm-labman:do-fix-label-name? >r
 336   0 to asm-labman:do-fix-label-name?
 337   ;; only CFA and PFA references are allowed
 338   dup asmx86:LABEL-TYPE-CFA = over asmx86:LABEL-TYPE-PFA = or asmx86:ERRID_ASM_INVALID_FORWARD_REF asmx86:not-?asm-error
 339   >r
 340   2dup x-tc-xcfind if
 341     ;; i found her!
 342     nrot 2drop
 343     r> asmx86:LABEL-TYPE-PFA = if tc-cfa->pfa endif
 344     1  ;; defined
 345   else
 346     ;; upcase it
 347     pad 256 + c4s:copy-counted
 348     pad 256 + count 2dup upcase-str
 349     0 r> asmx86:LABEL-TYPE-PFA = if tc-cfa->pfa endif
 350     dup >r
 351     ;; ( addr count value forward -- )
 352     true asmx86:asm-Make-Forth-Label
 353     r>
 354     -1  ;; undefined yet
 355   endif
 356   r> to asm-labman:do-fix-label-name?
 357 ;
 358
 359 ' tc-GetForthLabel to asmx86:asm-Get-Forth-Word