level1/70_compiler_90_helpers.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;; compile call to cfa
   9 ;; do not use comma directly, so high-level words will survive any threaded code changes
  10 ;; also, do not use this ONLY to compile calls to other words!
  11 ;; this is because of possible future optimiser
  12 : COMPILE,  ( cfa -- )
  13   forth:(opt-forth?) if optimiser:optimise-forth-call ifnot reladdr, endif else reladdr, endif
  14 ;
  15
  16 ;; compile CFA it is is not zero
  17 : ?COMPILE,  ( cfa//0 -- )  ?dup if compile, endif ;
  18
  19
  20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21 : [  ( -- )
  22   state 0!
  23 ; immediate
  24
  25 : ]  ( -- )
  26   state 1!
  27 ;
  28
  29
  30 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31 vocabulary COMPILER
  32 voc-set-active COMPILER
  33
  34 $variable "(CSP)" 0
  35 (hidden)
  36
  37 : !CSP  ( -- )  sp@ (csp) ! ;
  38 : ?CSP  ( -- )  sp@ (csp) @ - err-unfinished-definition ?error ;
  39 : ?COMP  ( -- )  state @ 0= err-compilation-only ?error ;
  40 : ?NON-MACRO  ( -- )  (latest-macro?) err-nonmacro-only ?error ;
  41 : ?EXEC  ( -- )  state @ err-execution-only ?error ;
  42
  43
  44 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  45 : forth-word-prologue  ( -- )
  46  $if URFORTH_DEBUG
  47   (dbginfo-reset)
  48   true to (dbginfo-active?)
  49  $endif
  50   $if URFORTH_ALIGN_CFA
  51   check-align-here
  52   $endif
  53   (URFORTH-DOFORTH-ADDR) compiler:(cfa-call,)
  54   $if URFORTH_ALIGN_PFA
  55   check-align-here
  56   $endif
  57 ;
  58
  59 : forth-word-epilogue  ( -- )
  60   create;
  61  $if URFORTH_DEBUG
  62   ;; save debug info (this also resets and deactivates it)
  63   (dbginfo-finalize-and-copy)
  64  $endif
  65 ;
  66
  67 : start-compile-forth-word  ( -- )
  68   forth-word-prologue [compile] ]
  69 ;
  70
  71 : end-compile-forth-word  ( -- )
  72   forth-word-epilogue
  73   smudge [compile] [
  74 ;
  75
  76
  77 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  78 ;; write 4-byte displacement for CALL/JMP jmpdest instruction to addr
  79 ;; addr should point after the instruction, at the first displacement byte
  80 : (DISP32!)  ( jmpdest addr -- )
  81   dup cell+ rot swap - swap !
  82 ; (hidden)
  83
  84 : (DISP32@)  ( addr -- jumpdest )
  85   dup @ swap cell+ +
  86 ; (hidden)
  87
  88 ;; write 5-byte CALL calldest machine instruction to addr
  89 : (CALL!)  ( calldest addr -- )
  90   0xe8 over c! 1+  ;; write CALL, advance address
  91   (disp32!)
  92 ; (hidden)
  93
  94 ;; write 5-byte JMP jmpdest machine instruction to addr
  95 : (JMP!)  ( jmpdest addr -- )
  96   0xe9 over c! 1+  ;; write JMP, advance address
  97   (disp32!)
  98 ; (hidden)
  99
 100 ;; compile 5-byte CALL calldest machine instruction to HERE
 101 : (CFA-CALL,)  ( calldest -- )
 102   $if URFORTH_ALIGN_CFA
 103   check-align-here
 104   $endif
 105   5 n-allot (call!)
 106   $if URFORTH_ALIGN_PFA
 107   align-here
 108   $endif
 109 ; (hidden)
 110
 111 ;; compile 5-byte JMP jmpdest machine instruction to HERE
 112 : (JMP,)  ( jmpdest -- )
 113   5 n-allot (jmp!)
 114 ; (hidden)
 115
 116
 117 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 118 : c4str-unaligned,  ( addr count -- )
 119   dup forth:unused 2u/ u>= ERR-STRING-TOO-LONG ?error
 120   ;; check if the string is at "here" (just in case)
 121   over here here cell+ 1- bounds? if  ;; move forward to make room for counter
 122     dup >r here cell+ swap move
 123     here cell+ r>
 124   endif
 125   dup cell+ n-allot  ( addr count destaddr )
 126   2dup ! cell+  ;; length
 127   swap move     ;; string itself
 128 ;
 129
 130 : c4str,  ( addr count -- )  c4str-unaligned, align-here ;
 131
 132 : c4strz-unaligned,  ( addr count -- ) c4str-unaligned, 0 c, ;
 133 : c4strz,  ( addr count -- )  c4strz-unaligned, align-here ;
 134
 135 : c1str-unaligned,  ( addr count -- )
 136   dup forth:unused 2u/ u>= ERR-STRING-TOO-LONG ?error
 137   dup 255 u> ERR-STRING-TOO-LONG ?error
 138   ;; check if the string is at "here" (just in case)
 139   over here = if  ;; move forward to make room for counter
 140     dup >r here 1+ swap move
 141     here 1+ r>
 142   endif
 143   dup 1+ n-allot  ( addr count destaddr )
 144   2dup c! 1+    ;; length
 145   swap move     ;; string itself
 146 ;
 147
 148 : c1str,  ( addr count -- )  c1str-unaligned, align-here ;
 149
 150 : c1strz-unaligned,  ( addr count -- )  c1str-unaligned, 0 c, ;
 151 : c1strz,  ( addr count -- )  c1strz-unaligned, align-here ;
 152
 153
 154 ;; byte-counted
 155 : custom-c1sliteral,  ( addr count cfa -- )
 156   ?dup if
 157     over 255 u> ERR-STRING-TOO-LONG ?error
 158     >r  ;; save cfa
 159     ;; check if the string is at "here" (just in case)
 160     over here here cell+ bounds? if  ;; move forward to make room for "litstr" and other things
 161       dup >r here cell+ swap move
 162       here cell+ r>
 163     endif
 164     r> compile,  ;; literal word
 165   endif
 166   c1strz,
 167 ;
 168
 169 : custom-c4sliteral,  ( addr count cfa -- )
 170   ?dup if
 171     over forth:unused 2u/ u>= ERR-STRING-TOO-LONG ?error
 172     >r  ;; save cfa
 173     ;; check if the string is at "here" (just in case)
 174     over here here 2 +cells 1- bounds? if  ;; move forward to make room for "litstr" and other things
 175       dup >r here 2 +cells swap move
 176       here 2 +cells r>
 177     endif
 178     r> compile,  ;; literal word
 179   endif
 180   c4strz,
 181 ;
 182
 183
 184 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 185 : literal,  ( n -- )
 186   dup case
 187      0 of drop compile lit0 endof
 188      1 of drop compile lit1 endof
 189     -1 of drop compile lit-1 endof
 190   $if URFORTH_ALIGN_PFA
 191     ;; no 8/16 bit literals
 192   $else
 193          0   256 within-of compile litu8 c, endof
 194       -128   128 within-of compile lits8 c, endof
 195          0 65536 within-of compile litu16 w, endof
 196     -32768 32768 within-of compile lits16 w, endof
 197   $endif
 198     compile lit ,
 199   endcase
 200 ;
 201
 202 : 2literal,  ( dlo dhi -- )  swap compiler:literal, compiler:literal, ;
 203 : addrliteral,  ( addr -- )  compile lit reladdr, ;
 204 : cfaliteral,  ( cfa -- )  compile litcfa reladdr, ;
 205 : c4sliteral,  ( addr count -- )  ['] litc4str custom-c4sliteral, ;
 206 : c1sliteral,  ( addr count -- )  ['] litc1str custom-c1sliteral, ;
 207 ;; puts byte-counted string literal if possible
 208 : sliteral,  ( addr count -- )
 209   dup 0 255 bounds? if ['] litc1str custom-c1sliteral,
 210   else ['] litc4str custom-c4sliteral, endif
 211 ;
 212
 213 voc-set-active FORTH
 214
 215
 216 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 217 ;; this is better done with custom creation word, but metacompiler cannot do that...
 218 : LITERAL  ( n -- )  state @ if compiler:literal, endif ; immediate
 219 : 2LITERAL  ( dlo dhi -- )  state @ if compiler:2literal, endif ; immediate
 220 : ADDRLITERAL  ( n -- )  state @ if compiler:addrliteral, endif ; immediate
 221 : CFALITERAL  ( cfa -- ) state @ if compiler:cfaliteral, endif ; immediate
 222 : C4SLITERAL  ( addr count -- )  state @ if compiler:c4sliteral, endif ; immediate
 223 : C1SLITERAL  ( addr count -- ) state @ if compiler:c1sliteral, endif ; immediate
 224 ;; puts byte-counted string literal if possible
 225 : SLITERAL  ( addr count -- )  state @ if compiler:sliteral, endif ; immediate