meta/meta-40-tc-compiler-04-low.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 : tc-c@  ( rva-addr -- c )  tc->real forth:c@ ;
  11 : tc-w@  ( rva-addr -- w )  tc->real forth:w@ ;
  12 : tc-@   ( rva-addr -- n )  tc->real forth:@ ;
  13
  14 : tc-c!  ( c rva-addr -- )  tc->real forth:c! ;
  15 : tc-w!  ( w rva-addr -- )  tc->real forth:w! ;
  16 : tc-!   ( n rva-addr -- )  tc->real forth:! ;
  17
  18
  19 : tc-here  ( -- ) elf-current-pc ;
  20
  21 : tc-n-allot  ( size -- rva-addr )
  22   metc-meta:mc-n-allot
  23 ;
  24
  25 : tc-c,  ( b -- )  tc-(dbginfo-add-here)  1 tc-n-allot tc-c! ;
  26 : tc-w,  ( w -- )  tc-(dbginfo-add-here)  2 tc-n-allot tc-w! ;
  27 : tc-,   ( n -- )  tc-(dbginfo-add-here)  4 tc-n-allot tc-! ;
  28
  29 ;; create relocation (currently does nothing)
  30 : tc-rel-create  ( addr -- )  ( tc-check-addr) drop ;
  31
  32 ;; the following can be customized for special builds
  33 : tc-reladdr,  ( dictaddr -- )
  34   tc-check-addr tc-here swap tc-, tc-rel-create
  35 ;
  36
  37
  38 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  39 ;; write 4-byte displacement for CALL/JMP jmpdest instruction to addr
  40 ;; addr should point after the instruction, at the first displacement byte
  41
  42 : tc-align-here  ( -- )
  43   tc-align-pfa if begin tc-here 3 and while 0 tc-c, 1 +to tc-align-pfa-wasted repeat endif
  44 ;
  45
  46 : tc-check-align-here  ( -- )
  47   tc-align-cfa tc-align-pfa or if
  48     tc-here 3 and if
  49       abort" align violation (internal metacompiler error)"
  50     endif
  51   endif
  52 ;
  53
  54 : tc-(DISP32!)  ( rva-jmpdest rva-addr -- )
  55   dup cell+ rot swap - swap tc-!
  56 ;
  57
  58 : tc-(DISP32@)  ( rva-addr -- rva-jumpdest )
  59   dup tc-@ swap cell+ +
  60 ;
  61
  62 : tc-(BYTE!)  ( byte rva-addr -- )
  63   tc-c!
  64 ;
  65
  66 ;; write 5-byte CALL calldest machine instruction to addr
  67 : tc-(CALL!)  ( rva-calldest rva-addr -- )
  68   0xe8 over tc-(byte!) 1+  ;; write CALL, advance address
  69   tc-(disp32!)
  70 ;
  71
  72 ;; write 5-byte JMP jmpdest machine instruction to addr
  73 : tc-(JMP!)  ( rva-jmpdest rva-addr -- )
  74   0xe9 over tc-(byte!) 1+  ;; write JMP, advance address
  75   tc-(disp32!)
  76 ;
  77
  78 : tc-(CFA-0CALL,)  ( -- rva-disp )
  79   tc-check-align-here
  80   0xe9 tc-c, tc-here 0 tc-, tc-align-here
  81 ;
  82
  83 ;; compile 5-byte CALL calldest machine instruction to HERE
  84 : tc-(CFA-CALL,)  ( rva-calldest -- )
  85   tc-check-align-here
  86   5 tc-n-allot tc-(call!) tc-align-here
  87 ;
  88
  89 ;; compile 5-byte JMP jmpdest machine instruction to HERE
  90 : tc-(JMP,)  ( rva-jmpdest -- )
  91   5 tc-n-allot tc-(jmp!)
  92   ;; do not align it
  93 ;
  94
  95
  96 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  97 ;; wordlist structure
  98 ;;   dd latest
  99 ;;   dd voclink (voclink always points here)
 100 ;;   dd parent (if not zero, all parent words are visible)
 101 ;;   dd header-nfa (can be 0 for anonymous wordlists)
 102 ;;   hashtable (if enabled)
 103
 104 4 constant tc-(voc-header-size-cells)
 105 : tc-vocid->voclink  ( rva-vocid -- rva-voclink )  cell+ ;
 106 : tc-vocid->parent   ( rva-vocid -- rva-parent )  2 +cells ;
 107 : tc-vocid->headnfa  ( rva-vocid -- rva-headernfa )  3 +cells ;
 108 : tc-vocid->htable   ( rva-vocid -- rva-hashtable )  4 +cells ;
 109 : tc-vocid-hashed?   ( rva-vocid -- flag )  tc-vocid->htable tc-@ -1 <> ;
 110
 111
 112 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 113 : tc-id-count  ( rva-nfa -- rva-addr rva-count )  dup tc-c@ swap cell+ swap ;
 114 : tc-type  ( rva-addr count -- )  swap tc->real swap type ;
 115 : tc-id.  ( nfa -- )  tc-id-count tc-type ;
 116
 117
 118 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 119 ;; this will be allocated when the first forth word is defined
 120 ;; because hashtable size is controlled by the WLIST_HASH_BITS constant
 121 ;; see "ensure-forth-hashtable"
 122 -1 value forth-hashtable-bits
 123
 124
 125 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 126 ;; hack: put it at the end of the memory
 127 ;; we'll move it to FORTH dictionary later
 128 0 value tc-current  ;; contains pointer to voclptr
 129 0 value tc-forth    ;; FORTH vocid (FORTH is the first created vocabulary)
 130
 131 ;; create headerless vocabulary structure (see above)
 132 : tc-alloc-vocab-data  ( -- rva-addr )
 133   forth-hashtable-bits 0< if
 134     s" WLIST_HASH_BITS" asmx86:asm-Get-Constant not-?abort" WLIST_HASH_BITS is not defined"
 135     dup 0 8 bounds? not-?abort" WLIST_HASH_BITS is out of range"
 136     to forth-hashtable-bits
 137     ." hashtable size: " 1 forth-hashtable-bits lshift cells . ." bytes, at rva 0x" tc-here .hex8 cr
 138   endif
 139   ;; calculate vocabulary size
 140   tc-(voc-header-size-cells) cells
 141   forth-hashtable-bits if 1 forth-hashtable-bits lshift +cells endif
 142   dup tc-n-allot  ;; ( size addr )
 143   dup tc->real rot erase
 144   ;; save to "forth_wordlist_vocid" label
 145   dup " forth_wordlist_vocid" rot asmx86:asm-Make-Label
 146   ;; and make "forth_wordlist_voclink" label
 147   dup tc-vocid->voclink " forth_wordlist_voclink" rot asmx86:asm-Make-Label
 148   tc-forth ?abort" wut?! double FORTH wordlist initialisation"
 149   dup to tc-forth
 150 ;
 151
 152 ;; actually, there is NO reason to not create a vocabulary right away
 153 ;; WARNING! TODO: redefine ALL vocabulary words to have pointers to the
 154 ;; actual vocabulary positions at their PFA, to avoid threating "FORTH"
 155 ;; as something special
 156 : ensure-forth-hashtable  ( -- )
 157   tc-current ifnot
 158     ;; we have no tc-current, which means that no vocabularies were created yet
 159     ;; create one, it will become "FORTH" later
 160     tc-alloc-vocab-data
 161     ;; we need indirect pointer to it, so waste one more cell for this
 162     ;; we will point our target "CURRENT" there too, because why not
 163     cell tc-n-allot dup to tc-current
 164     ;; and setup indirection
 165     tc-!
 166     ;; create label
 167     " IMAGE_CURRENT_VAR_ADDR" tc-current asmx86:asm-Make-Label
 168   endif
 169 ;