libs/asmx86/user-labelman.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Natural-syntax x86 assembler
   4 ;; Modelled after SMAL32 built-in assembler
   5 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   6 ;; GPLv3 ONLY
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;; label manager
   9 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 vocabulary asm-labman
  12 also asm-labman definitions
  13
  14 true constant lman-use-hash-table immediate
  15
  16 false value lman-debug immediate
  17 false value lman-fixup-debug immediate
  18 false value lman-debug-forth immediate
  19
  20 true value lman-allow-forth-implicit
  21
  22 (*
  23   we'll BRK all the needed memory, and will never free it
  24   this is totally unacceptable in long-running system, but
  25   ok for metacompiler and for systems that will be SAVEd.
  26
  27   sadly, we can't store address label links in the code itself
  28   (due to short jumps), so don't bother at all.
  29
  30   so, we have two linked lists: label names and flags, and fixups.
  31
  32   label name and info:
  33     cell next-in-bucket  ( or 0 )
  34     cell flags ( see below )
  35     cell value
  36     cell fixuphead ( or 0 )
  37     cell introline# ( tib-line# at the time this label was first introduced)
  38     c4str name ( uppercased )
  39
  40   flags:
  41     bit 0: undefined yet
  42     bit 1: forward reference
  43     bit 2: set for forth word reference (i.e. not a code label)
  44     bit 3: constant
  45     bit 31: hidden (so it can be checked with 0<) -- NOT YET
  46
  47   fixup list:
  48     cell next ( or 0 )
  49     cell addr
  50     cell type
  51     cell introline# ( generally, should be the same data structure as in nfo)
  52
  53   types:
  54     0: direct code address (4 bytes)
  55     1: long displacement (4 bytes)
  56     2: short displacement (1 byte)
  57
  58   @@ labels are done this way:
  59     when we see @@, we're going to resolve all @f, and remove it
  60     when we access @f, we're always remember it as a fixup
  61     when we access @b, we're adding it as @@ (so it will be automatically resolved)
  62 *)
  63
  64 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  65 5 constant nfo-size-cells  ;; w/o name
  66 0 var (mem-allocated)
  67
  68 0x01 constant flag-undefined
  69 0x02 constant flag-forward
  70 0x04 constant flag-forth
  71 0x08 constant flag-constant
  72
  73 0 constant fxtype-direct
  74 1 constant fxtype-disp32
  75 2 constant fxtype-disp8
  76
  77 ;; usually, "@" is removed from label name (due to "@name" labels being "global-non-reseting")
  78 ;; this is not necessary (and basically destructive) for Forth labels
  79 ;; hence this flag
  80 true value do-fix-label-name?
  81
  82
  83 ;; use 256 buckets, because it is the easiest way
  84 lman-use-hash-table [IF]
  85   0 value info-hash-buckets
  86   0 value info-hash-buckets-dirty
  87   \ 256 cells brk-buffer: info-hash-buckets
  88   \ info-hash-buckets 256 cells erase
  89 [ELSE]
  90   0 var info-list-head
  91 [ENDIF]
  92
  93
  94 : Reinit  ( -- )
  95   lman-use-hash-table [IF]
  96     info-hash-buckets ifnot 256 cells brk-alloc to info-hash-buckets endif
  97     info-hash-buckets-dirty ifnot 256 cells brk-alloc to info-hash-buckets-dirty endif
  98     info-hash-buckets 256 cells erase
  99     info-hash-buckets-dirty 256 cells erase
 100   [ELSE]
 101     info-list-head 0!
 102   [ENDIF]
 103   \ endcr ." LABELMAN: reinited!\n"
 104 ;
 105
 106 [IFDEF] forth:startup-chain-add
 107   ' Reinit startup-chain-add
 108 [ENDIF]
 109
 110 [IFDEF] forth:(startup-init)
 111 ..: forth:(startup-init)  Reinit  ;..
 112 [ENDIF]
 113
 114 : xalloc  ( size -- addr )
 115   dup (mem-allocated) +!
 116   brk-alloc
 117 ;
 118
 119
 120 \ error if flag is non-zero
 121 : ?lbl-error  ( addr count somevalue flag code -- addr count somevalue )
 122   swap if
 123     >r drop
 124     endcr ." <" type ." >"
 125     r> asmx86:asm-error
 126   else
 127     drop
 128   endif
 129 ;
 130
 131 \ error if flag is zero
 132 : not-?lbl-error  ( addr count somevalue flag code -- addr count somevalue )
 133   swap not swap ?lbl-error
 134 ;
 135
 136 : ?lbl-error-nx  ( addr count flag code -- addr count )
 137   0 nrot ?lbl-error drop
 138 ;
 139
 140 : not-?lbl-error-nx  ( addr count flag code -- addr count )
 141   swap not swap ?lbl-error-nx
 142 ;
 143
 144
 145 lman-debug lman-fixup-debug or lman-debug-forth or [IF]
 146 : lbl-debug-msg  ( lbladdr lblcount msgaddr msgcount -- lbladdr lblcount )
 147   endcr ." LMAN: " type ."  <" 2dup type ." >" cr
 148 ;
 149 [ENDIF]
 150
 151
 152 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 153 : nfo->nfa  ( addr -- addr )  5 +cells ;  \ to name area
 154 : nfo->ffa  ( addr -- addr )  1 +cells ;  \ to flags area
 155 : nfo->pfa  ( addr -- addr )  2 +cells ;  \ to value area
 156 : nfo->xfa  ( addr -- addr )  3 +cells ;  \ to fixup ptr area
 157 : nfo->dfa  ( addr -- addr )  4 +cells ;  \ to "first defined" area
 158
 159 4 constant fix-item-cells
 160 : fix->addr  ( addr -- addr ) 1 +cells ;
 161 : fix-addr@  ( addr -- fxaddr ) fix->addr @ ;
 162 : fix->type  ( addr -- addr ) 2 +cells ;
 163 : fix-type@  ( addr -- type ) fix->type @ ;
 164 : fix->dfa   ( addr -- addr ) 3 +cells ;
 165 : fix-dfa@   ( addr -- addr ) fix->dfa @ ;
 166
 167
 168 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 169 ;;
 170
 171 ;; DO NOT REORDER! some code checks for `@fb-@ >`, for example
 172 1 constant @fb-@
 173 2 constant @fb-b
 174 3 constant @fb-f
 175
 176 ;; remove "@" from global label
 177 : is-@fb?  ( addr count -- flag )
 178   dup 2 = ifnot 2drop false exit endif
 179   drop dup c@ [char] @ = ifnot drop false exit endif
 180   1+ c@
 181   case
 182     [char] @ of @fb-@ endof
 183     [char] B of @fb-b endof
 184     [char] F of @fb-f endof
 185     otherwise drop 0
 186   endcase
 187 ;
 188
 189 : fix-@b  ( addr count -- addr count )
 190   ;; "@b" should resolve to the last "@@", so simply replace the name
 191   2dup is-@fb? @fb-b = if 2drop " @@" endif
 192 ;
 193
 194 : is-local?  ( addr count -- flag )
 195   drop c@ [char] . =
 196 ;
 197
 198 : nfo-is-local?  ( nfo -- flag )
 199   ?dup ifnot false exit endif
 200   dup nfo->ffa @ flag-forth and if drop false exit endif
 201   nfo->nfa count is-local?
 202 ;
 203
 204 : fix-label-name  ( addr count -- addr count )
 205   do-fix-label-name? ifnot exit endif
 206   over c@ [char] @ = if
 207     2dup is-@fb? ifnot
 208       ;; remove '@'
 209       1- dup asmx86:ERRID_ASM_INVALID_LABEL_NAME not-?lbl-error-nx
 210       swap 1+ swap
 211       over c@ [char] @ = asmx86:ERRID_ASM_INVALID_LABEL_NAME ?lbl-error-nx
 212     endif
 213   endif
 214 ;
 215
 216
 217 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 218 ;; create DFA info and write it into the label
 219 ;; for now, we simply store the line number, but we should store
 220 ;; file name too
 221 : create-dfa  ( -- addr )
 222   asmx86:lexer:first-line# ?dup ifnot tib-line# @ endif
 223   ?dup if
 224     2 cells xalloc  ;; for line # and file name
 225     dup >r
 226     swap over ! cell+
 227     0 over ! cell+
 228     drop
 229     r>
 230   else
 231     0
 232   endif
 233 ;
 234
 235 : dfa-@line  ( dfa -- linenum )
 236   ?dup if @ else 0 endif
 237 ;
 238
 239 : dfa-@fname  ( dfa -- addr count )
 240   ?dup if cell+ @ ?dup if count exit endif endif
 241   NullString
 242 ;
 243
 244 : type-dfa  ( dfa -- )
 245   ?dup if
 246     dup dfa-@line ?dup if
 247       ."  around line #" base @ >r decimal 0 .r r> base !
 248     endif
 249     dfa-@fname dup if
 250       ."  of file \`" type ." \`"
 251     else
 252       2drop
 253     endif
 254   endif
 255 ;
 256
 257 : type-dfa-msg-cr  ( dfa addr count -- )
 258   rot ?dup if
 259     dup @ if
 260       nrot endcr type type-dfa cr
 261     else
 262       drop
 263       2drop
 264     endif
 265   else
 266     2drop
 267   endif
 268 ;
 269
 270 : create-label-dfa  ( nfo -- )
 271   nfo->dfa create-dfa swap !
 272 ;
 273
 274
 275 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 276 : lman-name-hash-folded  ( addr count -- u8 )
 277   str-name-hash uhash32->8
 278 ;
 279
 280
 281 : find-label  ( addr count -- nfo-block-addr 1 // 0 )
 282   fix-label-name
 283   lman-use-hash-table [IF]
 284     2dup lman-name-hash-folded info-hash-buckets cells^
 285   [ELSE]
 286     info-list-head
 287   [ENDIF]
 288   begin @ ?dup while
 289     >r
 290       \ 2dup type space r@ .hex8 space r@ nfo->nfa count type cr
 291     2dup r@ nfo->nfa count s=ci if 2drop r> true exit endif
 292   r> repeat 2drop false
 293 ;
 294
 295
 296 : create-label  ( addr count -- nfo-block-addr )
 297   fix-label-name
 298   dup 1 < asmx86:ERRID_ASM_INTERNAL_ERROR asmx86:?asm-error
 299   dup nfo-size-cells 1+ +cells xalloc  ;; name bytes, header, count
 300   >r
 301   ;; link it
 302   lman-use-hash-table [IF]
 303     2dup lman-name-hash-folded info-hash-buckets cells^
 304     dup @ r@ rot !
 305     r@ !
 306   [ELSE]
 307     info-list-head @ r@ !
 308     r@ info-list-head !
 309   [ENDIF]
 310   ;; clear other fields
 311   r@ cell+ nfo-size-cells 1- cells erase
 312   ;; copy name
 313   r@ nfo->nfa c4s:copy-counted
 314   ;; upcase label name here, because why not?
 315   \ r@ nfo->nfa count upcase-str
 316   ;; create "definition info"
 317   r@ create-label-dfa
 318   ;; done, return new info address
 319   r>
 320 ;
 321
 322
 323 : hide-label  ( nfo -- )
 324   ;; simply set name length to zero
 325   nfo->nfa
 326   lman-use-hash-table [IF]
 327     ;; mark bucket dirty
 328     dup @ if dup count lman-name-hash-folded info-hash-buckets-dirty cells^ 1! endif
 329   [ENDIF]
 330   0!
 331 ;
 332
 333
 334 : nfo-is-hidden?  ( nfo -- flag )
 335   nfo->nfa @ 0=
 336 ;
 337
 338
 339 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 340 : (nfo-xdump-name)  ( nfo -- )
 341   ?dup if
 342     nfo->nfa cell+  ;; assume that the counter is dead
 343     begin dup c@ dup 32 127 within while emit 1+ repeat 2drop
 344   endif
 345 ;
 346
 347 ;; remove all hidden labels from the list
 348 : compress-labels  ( -- )
 349   lman-use-hash-table [IFNOT]
 350     info-list-head
 351     begin dup @ ?dup while  ( ptr-to-prev-link curr-nfo )
 352       dup nfo-is-hidden? if
 353           \ dup endcr ." removing: " (nfo-xdump-name) cr
 354         ;; put out next link to prev link
 355         2dup @ swap !
 356         ;; the code will move to the next one by itself
 357         drop
 358       else
 359         ;; drop prev, and let the code continue from the current one
 360         nip
 361       endif
 362     repeat drop
 363   [ELSE]
 364     256 for  ;; for each bucket
 365       info-hash-buckets-dirty i +cells @ if  ;; dirty bucket
 366           \ endcr ." *** bucket " i . ." is dirty!\n"
 367         0 info-hash-buckets-dirty i +cells !
 368         0 info-hash-buckets i +cells
 369         begin @ dup while  ( prev curr )
 370           dup nfo-is-hidden? if
 371               \ endcr ." dropped label in bucket " i . cr
 372             over if 2dup @ swap !
 373             else dup @ i info-hash-buckets cells^ ! endif
 374           else nip dup endif
 375         repeat 2drop
 376       endif
 377     endfor
 378   [ENDIF]
 379 ;
 380
 381
 382 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 383 ;; calls cfa: ( nfo -- ... stopflag )
 384 ;; returns when the list is done, or when cfa returned non-zero
 385 ;; the result is cfa result or zero if the list is done
 386 ;; cfa can push any number of data before stopflag if stopflag is non-zero
 387 : foreach-label  ( cfa -- ... flag )
 388   lman-use-hash-table [IF]
 389     256 for  ;; for each bucket
 390       info-hash-buckets i +cells
 391       swap >r  ;; move cfa to rstack
 392       begin @ dup while
 393         ;; skip hidden labels
 394         dup nfo-is-hidden? ifnot
 395           ;; ( nfo | cfa )
 396           r@ over >r execute ?dup if 2rdrop unloop exit endif
 397           r>
 398         endif
 399       repeat drop r>
 400     endfor drop
 401   [ELSE]
 402     >r info-list-head begin @ dup while
 403       ;; skip hidden labels
 404       dup nfo-is-hidden? ifnot
 405         ;; ( nfo | cfa )
 406         r@ over >r execute ?dup if 2rdrop exit endif
 407         r>
 408       endif
 409     repeat drop rdrop
 410   [ENDIF]
 411   0
 412 ;
 413
 414
 415 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 416 : dump-label  ( nfo -- )
 417   ;; name
 418   dup nfo->nfa count type ." : 0x"
 419   ;; value
 420   dup nfo->pfa @ dup .hex8 ."  (" 0 .r ." ) ["
 421   ;; flags
 422   dup nfo->ffa @
 423     dup flag-undefined and if ." U" endif
 424     dup flag-forward and if ." F" endif
 425     dup flag-forth and ifnot ." A" endif
 426     dup flag-constant and if ." C" endif
 427   drop ." ]" dup nfo->dfa @ type-dfa cr
 428   ;; dump fixups
 429   nfo->xfa
 430   begin
 431     @ ?dup
 432   while
 433     endcr ."   0x" dup cell+ @ .hex8
 434     ."  (" dup 2 +cells @ 0 .r ." )"
 435     dup fix-dfa@ type-dfa
 436     cr
 437   repeat
 438 ;
 439
 440 : dump-labels  ( -- )
 441   endcr ." === LABELS ===\n"
 442   [: ( nfo -- 0 )
 443     endcr dump-label
 444     false
 445   ;] foreach-label drop
 446   ." ---------\n"
 447 ;
 448
 449
 450 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 451 ;;
 452 ;; note that the parser always uppercases the labels, so
 453 ;; you don't need to worry about that
 454 ;;
 455 ;; also note that '@' is a valid identifier character
 456 ;;
 457
 458 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 459 : Do-Fixups  ( addr count nfo value -- )
 460   over >r >r  ;; ( addr count nfo | nfo value )
 461   nfo->xfa
 462   begin
 463     @ ?dup
 464   while
 465     ;; ( addr count fixupitem | nfo value )
 466     dup fix-type@
 467     ;; fixup address contains an offset, so we need to add it to the value
 468     case
 469       fxtype-direct of
 470         ;; ( addr count fixupitem | nfo value )
 471         dup fix-addr@
 472           lman-fixup-debug [IF]
 473             ." FXOFS-DIRECT: " 1 rpick nfo->nfa count type
 474             ."  fixaddr: 0x" dup .hex8
 475             ."  [fixaddr]: 0x" dup asmx86:asm-d@ .hex8
 476             ."  value: 0x" r@ .hex8
 477             cr
 478           [ENDIF]
 479         ;; ( addr count fixupitem fixaddr | nfo value )
 480         dup asmx86:asm-d@ r@ +
 481         ;; ( addr count fixupitem fixaddr [fixaddr]+value | nfo value )
 482         swap asmx86:asm-d!
 483       endof
 484       fxtype-disp32 of
 485         ;; ( addr count fixupitem | nfo value )
 486         dup fix-addr@
 487           lman-fixup-debug [IF]
 488             ." FXOFS-DISP32: " 1 rpick nfo->nfa count type
 489             ."  fixaddr: 0x" dup .hex8
 490             ."  [fixaddr]: " dup asmx86:asm-d@ 0 .r
 491             ."  value: 0x" r@ .hex8
 492             cr
 493           [ENDIF]
 494         ;; ( addr count fixupitem fixaddr | nfo value )
 495         dup asmx86:asm-d@ r@ +
 496         ;; ( addr count fixupitem fixaddr [fixaddr]+value | nfo value )
 497         over 4+ -  ;; calc displacement
 498         swap
 499         ;; warn if could be short
 500         over -128 128 within if
 501           dup 1- asmx86:asm-c@ 0xe8 <> if
 502             ;; not call
 503             2>r dup fix-dfa@ " WARNING: jump range could be short" type-dfa-msg-cr
 504             2r>
 505           endif
 506         endif
 507         asmx86:asm-d!
 508       endof
 509       fxtype-disp8 of
 510         ;; ( addr count fixupitem | nfo value )
 511         dup fix-addr@
 512         ;; ( addr count fixupitem fxaddr | nfo value )
 513           lman-fixup-debug [IF]
 514             ." FXOFS-DISP8: " 1 rpick nfo->nfa count type
 515             ."  fixaddr: 0x" dup .hex8
 516             ."  [fixaddr]: " dup asmx86:asm-c@ c>s 0 .r
 517             ."  value: 0x" r@ .hex8
 518             cr
 519           [ENDIF]
 520         ;; ( addr count fixupitem fixaddr | nfo value )
 521         dup asmx86:asm-c@ c>s r@ +
 522         ;; ( addr count fixupitem fixaddr [fixaddr]+value | nfo value )
 523         ;; calc disp
 524         over 1+ -  ;; calc displacement
 525         ;; ( addr count fixupitem fixaddr disp | nfo value )
 526         dup -128 128 within ifnot
 527           2drop dup fix-dfa@ " ERROR: invalid jump range" type-dfa-msg-cr
 528           true asmx86:ERRID_ASM_JUMP_OUT_OF_RANGE ?lbl-error
 529         endif
 530         swap asmx86:asm-c!
 531       endof
 532       otherwise
 533         true asmx86:ERRID_ASM_INTERNAL_ERROR ?lbl-error
 534     endcase
 535   repeat
 536   ;; ( addr count | nfo value )
 537   2drop rdrop
 538   ;; clear fixup list
 539   r@ nfo->xfa 0!
 540   ;; reset undefined and forward flags
 541   flag-undefined flag-forward or r> nfo->ffa ~and!
 542 ;
 543
 544
 545 : Add-Fixup  ( nfo addr type -- )
 546   rot >r  ;; ( addr type | nfo )
 547   ;; allocate new fixup record
 548   fix-item-cells cells xalloc
 549   ;; ( addr type fxit | nfo )
 550   ;; setup link
 551   r@ nfo->xfa @ over !
 552   dup r> nfo->xfa !
 553   ;; setup type
 554   dup fix->type rot swap !
 555   ;; create definition info
 556   create-dfa over fix->dfa !
 557   ;; setup address
 558   fix->addr !
 559 ;
 560
 561
 562 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 563 ;; this is called by main driver
 564 ;; you can throw error here
 565 : MakeConstant  ( addr count value -- )
 566   >r
 567   lman-debug [IF]
 568     " MakeConstant" lbl-debug-msg
 569   [ENDIF]
 570
 571   ;; no "@@", "@f", "@b"
 572   2dup is-@fb? asmx86:ERRID_ASM_INVALID_LABEL_NAME ?lbl-error-nx
 573
 574   2dup find-label asmx86:ERRID_ASM_DUPLICATE_CONSTANT ?lbl-error
 575   create-label
 576   ;; set value
 577   dup nfo->pfa r> swap !
 578   ;; set flags
 579   dup nfo->ffa flag-constant swap !
 580   ;; done
 581   drop
 582 ;
 583
 584
 585 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 586 : Check-Locals-Resolved  ( -- )
 587   false
 588   [: ( errflag nfo -- errflag 0 )
 589     dup nfo-is-local? if
 590       dup nfo->xfa @ if
 591         \ nfo->nfa count true asmx86:ERRID_ASM_UNRESOLVED_LABEL ?lbl-error-nx
 592         over ifnot endcr ." unresolved local label(s):\n" endif
 593         dup nfo->nfa count 2 spaces type
 594         dup nfo->dfa @ type-dfa cr
 595         nip true swap
 596       endif
 597     endif
 598     drop
 599     false
 600   ;] foreach-label drop
 601   asmx86:ERRID_ASM_UNRESOLVED_LABEL asmx86:?asm-error
 602 ;
 603
 604 : Clear-Locals  ( -- )
 605   [: ( nfo -- 0 )
 606     dup nfo-is-local? if
 607       dup hide-label
 608     endif
 609     drop
 610     false
 611   ;] foreach-label drop
 612 ;
 613
 614
 615 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 616 : Check-@@-Resolved  ( -- )
 617   [: ( nfo -- 0 )
 618     dup nfo->nfa count is-@fb? if
 619       dup nfo->xfa @ if
 620         nfo->nfa count true asmx86:ERRID_ASM_UNRESOLVED_LABEL ?lbl-error-nx
 621       endif
 622     endif
 623     drop
 624     false
 625   ;] foreach-label drop
 626 ;
 627
 628 : Clear-@@  ( -- )
 629   [: ( nfo -- 0 )
 630     dup nfo->nfa count is-@fb? if
 631       dup hide-label
 632     endif
 633     drop
 634     false
 635   ;] foreach-label drop
 636 ;
 637
 638
 639 ;; resolve "@f" to asm-PC, remove any existing "@@" label
 640 : Resolve-@f-And-Remove-@@  ( -- )
 641   [: ( nfo -- 0 )
 642     dup nfo->nfa count is-@fb?
 643     case
 644       @fb-f of
 645         ;; resolve and remove
 646         dup " @f" rot asmx86:asm-PC Do-Fixups
 647         dup hide-label
 648       endof
 649       @fb-@ of
 650         ;; simply remove (code cannot access "@@" directly, so no need to resolve it)
 651         dup hide-label
 652       endof
 653     endcase
 654     drop
 655     false
 656   ;] foreach-label drop
 657 ;
 658
 659
 660 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 661 : Clear-Unresolved  ( -- )
 662   [: ( nfo -- 0 )
 663     ;; do not clear forwards
 664     dup nfo->ffa @  flag-undefined flag-forward or and  flag-undefined =
 665     if
 666       dup hide-label
 667     endif
 668     drop
 669     false
 670   ;] foreach-label drop
 671 ;
 672
 673
 674 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 675 : Check-Unresolved  ( -- )
 676   false
 677   [: ( errflag nfo -- errflag 0 )
 678     ;; do not report forwards
 679     dup nfo->ffa @  flag-undefined flag-forward or and  flag-undefined =
 680     if
 681       \ nfo->nfa count true asmx86:ERRID_ASM_UNRESOLVED_LABEL ?lbl-error-nx
 682       over ifnot endcr ." unresolved label(s):\n" endif
 683       dup nfo->nfa count 2 spaces type
 684       dup nfo->dfa @ type-dfa cr
 685       nip true swap
 686     endif
 687     drop
 688     false
 689   ;] foreach-label drop
 690   asmx86:ERRID_ASM_UNRESOLVED_LABEL asmx86:?asm-error
 691 ;
 692
 693
 694 : Check-Unresolved-Forwards  ( -- )
 695   false
 696   [: ( errflag nfo -- errflag 0 )
 697     ;; do not report forwards
 698     dup nfo->ffa @  flag-undefined flag-forward or and  flag-undefined flag-forward or =
 699     if
 700       \ nfo->nfa count true asmx86:ERRID_ASM_UNRESOLVED_LABEL ?lbl-error-nx
 701       over ifnot endcr ." unresolved forward(s):\n" endif
 702       dup nfo->nfa count 2 spaces type
 703       dup nfo->dfa @ type-dfa cr
 704       nip true swap
 705     endif
 706     drop
 707     false
 708   ;] foreach-label drop
 709   asmx86:ERRID_ASM_UNRESOLVED_LABEL asmx86:?asm-error
 710 ;
 711
 712 : Count-Live-Labels  ( -- n )
 713   0 [: ( count nfo -- count 0 )
 714     drop 1+
 715     false
 716   ;] foreach-label drop
 717 ;
 718
 719
 720 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 721 ;; this is called by main driver
 722 ;; you can throw error here
 723 : MakeLabel  ( addr count value -- )
 724   >r
 725   lman-debug [IF]
 726     " MakeLabel" lbl-debug-msg
 727   [ENDIF]
 728
 729   ;; check for special labels
 730   over c@ [char] @ = if
 731     ;; no "@f", "@b"
 732     2dup is-@fb? @fb-@ > asmx86:ERRID_ASM_INVALID_LABEL_NAME ?lbl-error-nx
 733     ;; resolve "@@"
 734     2dup is-@fb? @fb-@ = if Resolve-@f-And-Remove-@@ endif
 735   else
 736     ;; non-local label should clear all locals
 737     2dup is-local? ifnot
 738       Check-Locals-Resolved
 739       Clear-Locals
 740     endif
 741   endif
 742
 743   2dup find-label if
 744     ;; existing label, check type
 745     dup nfo->ffa @ flag-undefined flag-forward or bitnot and asmx86:ERRID_ASM_DUPLICATE_LABEL ?lbl-error
 746     dup nfo->ffa @ flag-undefined and asmx86:ERRID_ASM_DUPLICATE_LABEL not-?lbl-error
 747     ;; fix addresses
 748     ;; ( addr count nfo | value )
 749     ;; set new value
 750     r@ over nfo->pfa !
 751       ;; endcr dup dump-label
 752     r> Do-Fixups
 753   else
 754     ;; new label
 755     create-label
 756     ;; set value
 757     dup nfo->pfa r> swap !
 758     ;; done
 759     drop
 760   endif
 761 ;
 762
 763
 764 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 765 ;; EXTERNAL API
 766 : MakeForthLabel  ( addr count value forward -- )
 767   do-fix-label-name? >r 0 to do-fix-label-name?
 768   >r >r  ;; ( addr count | forward value )
 769   dup asmx86:ERRID_ASM_INVALID_LABEL_NAME not-?lbl-error-nx
 770   2dup find-label if
 771     ;; existing label, check type
 772     dup nfo->ffa @ flag-undefined and asmx86:ERRID_ASM_DUPLICATE_LABEL not-?lbl-error
 773     dup nfo->ffa @ flag-forth and asmx86:ERRID_ASM_DUPLICATE_LABEL not-?lbl-error
 774     nrot 2drop  ;; drop label name, we don't need it anymore
 775   else
 776     ;; new label
 777     create-label
 778     ;; mark it as Forth label
 779     dup nfo->ffa flag-forth swap or!
 780   endif
 781   ;; ( nfo | forward value )
 782   ;; set value
 783   dup nfo->pfa r> swap !
 784   ;; ( nfo | forward )
 785   ;; set type
 786   r> ifnot
 787     ;; not forward
 788     dup nfo->ffa flag-undefined flag-forward or swap ~and!
 789     dup nfo->nfa count rot
 790     ;; ( addr count nfo )
 791     dup nfo->pfa @ Do-Fixups
 792   else
 793     dup nfo->ffa flag-undefined flag-forward or swap or!
 794     drop
 795   endif
 796   r> to do-fix-label-name?
 797 ;
 798
 799
 800 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 801 ;; EXTERNAL API
 802 ;; "-1" means that the label is not defined yet, and the value is a random prediction
 803 : GetForthLabel  ( addr count type -- value 1 // value -1 // false )
 804   >r wfind if
 805     r> case
 806       asmx86:LABEL-TYPE-CFA of forth:noop endof
 807       asmx86:LABEL-TYPE-PFA of forth:cfa->pfa endof
 808       \ asmx86:LABEL-TYPE-NFA of forth:cfa->nfa endof
 809       \ asmx86:LABEL-TYPE-LFA of forth:cfa->nfa forth:nfa->lfa endof
 810       \ asmx86:LABEL-TYPE-BFA of forth:cfa->nfa forth:nfa->bfa endof
 811       \ asmx86:LABEL-TYPE-SFA of forth:cfa->nfa forth:nfa->sfa endof
 812       \ asmx86:LABEL-TYPE-DFA of forth:cfa->nfa forth:nfa->dfa endof
 813       \ asmx86:LABEL-TYPE-HFA of forth:cfa->nfa forth:nfa->hfa endof
 814       asmx86:ERRID_ASM_INTERNAL_ERROR asmx86:asm-error
 815     endcase
 816     1
 817   else
 818     rdrop ;; 2drop
 819     false
 820   endif
 821 ;
 822
 823
 824 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 825 ;; EXTERNAL API
 826 : GetConstant  ( addr count -- value true // false )
 827   lman-debug [IF]
 828     " GetConstant(00)" lbl-debug-msg
 829   [ENDIF]
 830   ;; no "@@", "@f", "@b"
 831   2dup is-@fb? if 2drop false exit endif
 832   lman-debug [IF]
 833     " GetConstant(01)" lbl-debug-msg
 834   [ENDIF]
 835   ;; check label type
 836   2dup find-label ifnot 2drop false exit endif
 837   dup nfo->ffa @ flag-constant and if
 838     lman-debug [IF]
 839       >r
 840       endcr ." GetConstant: <" 2dup type ." :" r@ nfo->pfa @ 0 .r ." >" cr
 841       r>
 842     [ENDIF]
 843     nfo->pfa @
 844     nrot 2drop
 845     true
 846   else
 847     drop 2drop false
 848   endif
 849 ;
 850
 851
 852 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 853 ;; EXTERNAL API
 854 ;; "-1" means that the label is not defined yet, and the value is a random prediction
 855 : GetLabel  ( addr count -- value 1 // value -1 // false )
 856   lman-debug [IF]
 857     " GetLabel(00)" lbl-debug-msg
 858   [ENDIF]
 859   ;; no "@@"
 860   2dup is-@fb? @fb-@ = asmx86:ERRID_ASM_INVALID_LABEL_NAME ?lbl-error-nx
 861   ;; "@b" should resolve to the last "@@", so simply replace the name
 862   fix-@b
 863   lman-debug [IF]
 864     " GetLabel(01)" lbl-debug-msg
 865   [ENDIF]
 866   ;; check if such label exists
 867   2dup find-label ifnot
 868     ;; "@b" without "@@" should not be allowed
 869     2dup is-@fb? @fb-b = asmx86:ERRID_ASM_INVALID_BACKWARD_REF ?lbl-error-nx
 870     ;; create new label
 871     create-label
 872     ;; set flags
 873     dup nfo->ffa flag-undefined
 874       asmx86:asm-Labman-Unresolved-As-Forwards? if flag-forward or endif
 875     swap !
 876     ;; predict value (our predictor is highly sophisticated!)
 877     asmx86:asm-$ dup rot nfo->pfa !
 878     -1  ;; random predition
 879   else
 880     ;; check label type
 881     dup nfo->ffa @ flag-constant and asmx86:ERRID_ASM_TYPE_MISMATCH ?lbl-error
 882     ;; drop label name
 883     >r 2drop r>
 884     ;; return value
 885     dup nfo->pfa @
 886     ;; is it undefined?
 887     swap nfo->ffa @ flag-undefined and if -1 else 1 endif
 888   endif
 889 ;
 890
 891
 892 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 893 ;; EXTERNAL API
 894 : LabelDefined?  ( addr count -- flag )
 895   lman-debug [IF]
 896     " LabelDefined?(00)" lbl-debug-msg
 897   [ENDIF]
 898   ;; "@f" is never defined
 899   2dup is-@fb? @fb-f = if 2drop false exit endif
 900   ;; "@b" is defined if "@@" is defined, so simply replace the name
 901   fix-@b
 902   lman-debug [IF]
 903     " LabelDefined?(01)" lbl-debug-msg
 904   [ENDIF]
 905   ;; check if such label exists
 906   find-label ifnot false exit endif
 907   ;; check flags
 908   nfo->ffa @ flag-undefined and not
 909 ;
 910
 911
 912 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 913 : JxxFixupLabel  ( addr count disp32flag -- )
 914   >r  ;; move that flag away, we'll use it later
 915   ;; "@b" should resolve to the last "@@", so simply replace the name
 916   fix-@b
 917   lman-fixup-debug [IF]
 918     " JxxFixupLabel" lbl-debug-msg
 919   [ENDIF]
 920   ;; the label must be already created here
 921   \ 2dup find-label asmx86:ERRID_ASM_UNRESOLVED_LABEL not-?lbl-error-nx
 922   2dup find-label ifnot
 923     lman-allow-forth-implicit if
 924       2dup wfind asmx86:ERRID_ASM_UNRESOLVED_LABEL not-?lbl-error-nx
 925       ;; drop all crap
 926       rdrop drop 2drop
 927     else false asmx86:ERRID_ASM_UNRESOLVED_LABEL not-?lbl-error-nx
 928     endif
 929   else
 930     ;; and it must be a code label
 931     dup nfo->ffa @ flag-constant and asmx86:ERRID_ASM_TYPE_MISMATCH ?lbl-error-nx
 932     ;; check if we have to add the asm-PC to the fixup list
 933     dup nfo->ffa @ flag-undefined and if
 934       ;; yeah, append it
 935       dup asmx86:asm-PC r@ if fxtype-disp32 else fxtype-disp8 endif Add-Fixup
 936     endif
 937     ;; drop all crap
 938     rdrop drop 2drop
 939   endif
 940 ;
 941
 942
 943 ;; EXTERNAL API
 944 : FixupJmpLabel  ( addr count type -- )
 945   ;; ignore label type (for now)
 946   ;; label creation code should make sure that the Forth fixup add (in memory) is right for CFA/PFA/ETC
 947   drop
 948   lman-fixup-debug [IF]
 949     " FixupJmpLabel" lbl-debug-msg
 950   [ENDIF]
 951   true JxxFixupLabel
 952 ;
 953
 954
 955 ;; EXTERNAL API
 956 : FixupJRLabel  ( addr count type -- )
 957   ;; ignore label type (for now)
 958   ;; label creation code should make sure that the Forth fixup add (in memory) is right for CFA/PFA/ETC
 959   drop
 960   lman-fixup-debug [IF]
 961     " FixupJRLabel" lbl-debug-msg
 962   [ENDIF]
 963   false JxxFixupLabel
 964 ;
 965
 966
 967 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 968 ;; EXTERNAL API
 969 : LabelFixup  ( addr count size type -- )
 970   ;; ignore label type (for now)
 971   ;; label creation code should make sure that the Forth fixup add (in memory) is right for CFA/PFA/ETC
 972   drop
 973   4 = asmx86:ERRID_ASM_INVALID_FORWARD_REF asmx86:not-?asm-error
 974   lman-fixup-debug [IF]
 975     " LabelFixup" lbl-debug-msg
 976   [ENDIF]
 977   ;; the label must be already created here
 978   2dup find-label
 979   lman-allow-forth-implicit if
 980     ifnot
 981       2dup wfind if drop 2drop exit endif
 982       false asmx86:ERRID_ASM_UNRESOLVED_LABEL not-?lbl-error-nx
 983     endif
 984   else
 985     asmx86:ERRID_ASM_UNRESOLVED_LABEL not-?lbl-error-nx
 986   endif
 987   ;; and it must not be a constant
 988   dup nfo->ffa @ flag-constant and asmx86:ERRID_ASM_TYPE_MISMATCH ?lbl-error-nx
 989   ;; check if we have to add the asm-PC to the fixup list
 990   dup nfo->ffa @ flag-undefined and if
 991     ;; yeah, append it
 992     lman-fixup-debug [IF]
 993       ." LabelFixup NEW: " dup nfo->nfa count type
 994       ."  fixaddr: 0x" asmx86:asm-PC .hex8
 995       ."  [fixaddr]: 0x" asmx86:asm-PC asmx86:asm-d@ .hex8
 996       cr
 997     [ENDIF]
 998     dup asmx86:asm-PC fxtype-direct Add-Fixup
 999   endif
1000   ;; and drop all crap
1001   drop 2drop
1002 ;
1003
1004
1005 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1006 ;; called by "CODE:" compiler
1007 : CheckUndefLabels  ( -- )
1008   lman-debug [IF]
1009     dump-labels
1010   [ENDIF]
1011   Check-Locals-Resolved
1012   Clear-Locals
1013   Check-@@-Resolved
1014   Clear-@@
1015   Check-Unresolved
1016   ;; cheat for speed
1017   compress-labels
1018   \ Count-Live-Labels ifnot Reinit endif
1019 ;
1020
1021
1022 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1023 ;; used by metacompiler
1024 ;; called before metacompiler is going to generate the binary
1025 : FinalCheckUndefLabels  ( -- )
1026   CheckUndefLabels
1027   Check-Unresolved-Forwards
1028   ;; cheat for speed
1029   compress-labels
1030   \ Count-Live-Labels ifnot Reinit endif
1031 ;
1032
1033
1034 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1035 ;; called by `asm-error`
1036 : ErrorReset  ( -- )
1037   Clear-Locals
1038   Clear-@@
1039   Clear-Unresolved
1040   ;; cheat for speed
1041   compress-labels
1042   \ Count-Live-Labels ifnot Reinit endif
1043 ;
1044
1045
1046 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1047 Reinit
1048
1049
1050 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1051 previous definitions
1052
1053 ;; plug in our label manager
1054
1055 ' asm-labman:ErrorReset to asmx86:asm-Labman-Error-Reset
1056 ' asm-labman:Reinit to asmx86:asm-Labman-Reinit
1057 ' asm-labman:MakeConstant to asmx86:asm-Make-Constant
1058 ' asm-labman:MakeLabel to asmx86:asm-Make-Label
1059 ' asm-labman:MakeForthLabel to asmx86:asm-Make-Forth-Label
1060 ' asm-labman:GetForthLabel to asmx86:asm-Get-Forth-Word
1061 ' asm-labman:GetLabel to asmx86:asm-Get-Label
1062 ' asm-labman:GetConstant to asmx86:asm-Get-Constant
1063 ' asm-labman:LabelDefined? to asmx86:asm-Label-Defined?
1064 ' asm-labman:FixupJmpLabel to asmx86:asm-Jmp-Label-Fixup
1065 ' asm-labman:FixupJRLabel to asmx86:asm-JR-Label-Fixup
1066 ' asm-labman:LabelFixup to asmx86:asm-Label-Fixup
1067 ' asm-labman:CheckUndefLabels to asmx86:asm-Check-Undef-Labels
1068 ' asm-labman:FinalCheckUndefLabels to asmx86:asm-Check-Undef-Labels-Final
1069 ' asm-labman:dump-labels to asmx86:asm-Dump-Labels