level1/10_litbase.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 ;; fun observation: cmov seems to be slower than jumps
   8 URF_USE_CMOV_IN_BRANCHES equ 0
   9
  10
  11 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12 code: NOOP  ( -- )
  13   urnext
  14 endcode
  15
  16
  17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18 code: LIT-FALSE  ( -- 0 )
  19   push  TOS
  20   xor   TOS,TOS
  21   urnext
  22 endcode
  23 (hidden)
  24
  25 code: LIT-TRUE  ( -- 1 )
  26   push  TOS
  27   xor   TOS,TOS
  28   inc   TOS
  29   urnext
  30 endcode
  31 (hidden)
  32
  33
  34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  35 code: LIT0  ( -- 0 )
  36   push  TOS
  37   xor   TOS,TOS
  38   urnext
  39 endcode
  40 (hidden)
  41
  42 code: LIT1  ( -- 1 )
  43   push  TOS
  44   xor   TOS,TOS
  45   inc   TOS
  46   urnext
  47 endcode
  48 (hidden)
  49
  50 code: LIT-1  ( -- -1 )
  51   push  TOS
  52   xor   TOS,TOS
  53   dec   TOS
  54   urnext
  55 endcode
  56 (hidden)
  57
  58 code: LIT  ( -- n )
  59   push  TOS
  60   lodsd
  61   ld    TOS,eax
  62   urnext
  63 endcode
  64 (arg-lit) (hidden)
  65
  66 $ifnot URFORTH_ALIGN_PFA
  67 code: LITU8  ( -- n )
  68   push  TOS
  69   lodsb
  70   movzx TOS,al
  71   urnext
  72 endcode
  73 (arg-u8) (hidden)
  74
  75 code: LITS8  ( -- n )
  76   push  TOS
  77   lodsb
  78   movsx TOS,al
  79   urnext
  80 endcode
  81 (arg-s8) (hidden)
  82
  83 code: LITU16  ( -- n )
  84   push  TOS
  85   lodsw
  86   movzx TOS,ax
  87   urnext
  88 endcode
  89 (arg-u16) (hidden)
  90
  91 code: LITS16  ( -- n )
  92   push  TOS
  93   lodsw
  94   movsx TOS,ax
  95   urnext
  96 endcode
  97 (arg-s16) (hidden)
  98 $endif
  99
 100
 101 code: LITC4STR  ( -- addr count )
 102   push  TOS
 103   lodsd
 104   push  EIP
 105   mov   TOS,eax
 106   add   EIP,eax
 107   ;; skip trailing zero and align
 108   or    EIP,3
 109   inc   EIP
 110   urnext
 111 endcode
 112 (arg-c4strz) (hidden)
 113
 114 code: LITC1STR  ( -- addr count )
 115   push  TOS
 116   lodsb
 117   movzx TOS,al
 118   push  EIP
 119   add   EIP,TOS
 120   ;; skip trailing zero and align
 121   or    EIP,3
 122   inc   EIP
 123   urnext
 124 endcode
 125 (arg-c1strz) (hidden)
 126
 127 code: LITCFA
 128   push  TOS
 129   lodsd
 130   mov   TOS,eax
 131   urnext
 132 endcode
 133 (arg-cfa) (hidden)
 134
 135 code: LITCBLOCK
 136   ;; next cell is continue address
 137   ;; leave next next cell address as cfa
 138   push  TOS
 139   lodsd
 140   ld    TOS,EIP
 141   ld    EIP,eax
 142   urnext
 143 endcode
 144 (arg-cblock) (hidden)
 145
 146 ;; used in "TO"
 147 code: LITTO!  ( value -- )
 148   lodsd
 149   $if URFORTH_ALIGN_PFA
 150   add   eax,8   ;; skip cfa
 151   $else
 152   add   eax,5   ;; skip cfa
 153   $endif
 154   ld    [eax],TOS
 155   pop   TOS
 156   urnext
 157 endcode
 158 (arg-cfa) (hidden)
 159
 160 ;; used in "TO"
 161 code: LIT^TO  ( -- dataaddr )
 162   lodsd
 163   $if URFORTH_ALIGN_PFA
 164   add   eax,8   ;; skip cfa
 165   $else
 166   add   eax,5   ;; skip cfa
 167   $endif
 168   push  TOS
 169   ld    TOS,eax
 170   urnext
 171 endcode
 172 (arg-cfa) (hidden)
 173
 174 ;; used in "+TO"
 175 code: LIT+TO!  ( value -- )
 176   lodsd
 177   $if URFORTH_ALIGN_PFA
 178   add   eax,8   ;; skip cfa
 179   $else
 180   add   eax,5   ;; skip cfa
 181   $endif
 182   add   [eax],TOS
 183   pop   TOS
 184   urnext
 185 endcode
 186 (arg-cfa) (hidden)
 187
 188 ;; used in "-TO"
 189 code: LIT-TO!  ( value -- )
 190   lodsd
 191   $if URFORTH_ALIGN_PFA
 192   add   eax,8   ;; skip cfa
 193   $else
 194   add   eax,5   ;; skip cfa
 195   $endif
 196   sub   [eax],TOS
 197   pop   TOS
 198   urnext
 199 endcode
 200 (arg-cfa) (hidden)
 201
 202 code: LIT-EXECTAIL  ( -- )
 203   lodsd
 204   popr  EIP
 205   jp    eax
 206 endcode
 207 (arg-cfa) (noreturn) (hidden)
 208
 209
 210 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 211 code: BRANCH
 212   lodsd
 213   mov   EIP,eax
 214   urnext
 215 endcode
 216 (arg-branch) (hidden)
 217
 218 code: 0BRANCH
 219   lodsd
 220   test  TOS,TOS
 221   pop   TOS
 222  $if URF_USE_CMOV_IN_BRANCHES
 223   cmovz EIP,eax
 224  $else
 225   jr    nz,@f
 226   mov   EIP,eax
 227 @@:
 228  $endif
 229   urnext
 230 endcode
 231 (arg-branch) (hidden)
 232
 233 code: TBRANCH
 234   lodsd
 235   test  TOS,TOS
 236   pop   TOS
 237  $if URF_USE_CMOV_IN_BRANCHES
 238   cmovnz EIP,eax
 239  $else
 240   jr    z,@f
 241   mov   EIP,eax
 242 @@:
 243  $endif
 244   urnext
 245 endcode
 246 (arg-branch) (hidden)
 247
 248 ;; branch if positive or zero
 249 code: +0BRANCH
 250   lodsd
 251   cp    TOS,0
 252   pop   TOS
 253  $if URF_USE_CMOV_IN_BRANCHES
 254   cmovge EIP,eax
 255  $else
 256   jr    l,@f
 257   ld    EIP,eax
 258 @@:
 259  $endif
 260   urnext
 261 endcode
 262 (arg-branch) (hidden)
 263
 264 ;; branch if negative or zero
 265 code: -0BRANCH
 266   lodsd
 267   cp    TOS,0
 268   pop   TOS
 269  $if URF_USE_CMOV_IN_BRANCHES
 270   cmovle EIP,eax
 271  $else
 272   jr    g,@f
 273   ld    EIP,eax
 274 @@:
 275  $endif
 276   urnext
 277 endcode
 278 (arg-branch) (hidden)
 279
 280 ;; used in "CASE": drops additional value if branch is NOT taken
 281 code: 0BRANCH-DROP
 282   lodsd
 283   test  TOS,TOS
 284   pop   TOS
 285  $if URF_USE_CMOV_IN_BRANCHES
 286   cmovz EIP,eax
 287   jr    z,@f
 288   ;; branch not taken, drop one more data value
 289   pop   TOS
 290 @@:
 291  $else
 292   jr    nz,@f
 293   mov   EIP,eax
 294   urnext
 295 @@:
 296   ;; branch not taken, drop one more data value
 297   pop   TOS
 298  $endif
 299   urnext
 300 endcode
 301 (arg-branch) (hidden)
 302
 303 ;; if two values on the stack are equal, drop them, and take a branch
 304 ;; if they aren't equal, do nothing
 305 code: ?DO-BRANCH
 306   lodsd
 307   cp    TOS,[esp]
 308   jr    nz,@f
 309   ;; values are equal, drop them, and take a branch
 310   pop   TOS
 311   pop   TOS
 312   mov   EIP,eax
 313 @@:
 314   urnext
 315 endcode
 316 (arg-branch) (hidden)
 317
 318
 319 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 320 code: EXECUTE
 321   mov   eax,TOS
 322   pop   TOS
 323   jp    eax
 324 endcode
 325
 326 ;; tail call (will not return to the caller)
 327 code: EXECUTE-TAIL
 328   mov   eax,TOS
 329   popr  EIP
 330   pop   TOS
 331   jp    eax
 332 endcode
 333 (noreturn)
 334
 335 code: @EXECUTE
 336   mov   eax,[TOS]
 337   pop   TOS
 338   jp    eax
 339 endcode
 340
 341 ;; tail call (will not return to the caller)
 342 code: @EXECUTE-TAIL
 343   mov   eax,[TOS]
 344   popr  EIP
 345   pop   TOS
 346   jp    eax
 347 endcode
 348 (noreturn)
 349
 350 code: OVERRIDE-EXECUTE
 351 ;; ( ... xtoken -- ... )
 352   mov   eax,TOS
 353   pop   TOS
 354   pushr EIP
 355   ld    EIP,eax
 356   urnext
 357 endcode
 358
 359 code: EXIT
 360   popr  EIP
 361   urnext
 362 endcode
 363 (noreturn)
 364
 365
 366 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 367 ;; this is support for "FOR"
 368 ;; it checks if the value on the stack is positive
 369 ;; if it is not (or zero), it drops the value, and jumps
 370 ;; if the value is positive, it prepares the stack in the
 371 ;; same manner as "(DO)" does
 372 code: (FOR)
 373   lodsd
 374   cp    TOS,1
 375   jr    ge,.initloop
 376   ;; skip it
 377   mov   EIP,eax
 378   jr    .done
 379 .initloop:
 380   ;; prepare stack as "(DO)" does (so `I` and `(LOOP)` could work)
 381   ld    edx,0x80000000
 382   sub   edx,TOS
 383   sub   ERP,4+4
 384   ld    [ERP],edx
 385   ld    [ERP+4],edx
 386 .done:
 387   pop   TOS
 388   urnext
 389 endcode
 390 (arg-branch) (hidden)
 391
 392 ;; loops from start to limit-1
 393 code: (DO)  ( limit start -- | limit counter )
 394   ;; ANS loops
 395   pop   eax
 396   ld    edx,0x80000000
 397   sub   edx,eax
 398   add   TOS,edx
 399   sub   ERP,4+4
 400   ld    [ERP+4],edx  ;; 80000000h-to
 401   ld    [ERP],TOS    ;; 80000000h-to+from
 402   pop   TOS
 403   urnext
 404 endcode
 405 (hidden)
 406
 407 code: (+LOOP)  ( delta -- | limit counter )
 408   ;; ANS loops
 409   ;; most of the time we need jump address, so always load it
 410   ;; it also frees us from "add EIP,4" on exit
 411   lodsd
 412   add   TOS,[ERP]
 413   jr    o,.done
 414   ;; next iteration
 415   ld    [ERP],TOS
 416   mov   EIP,eax
 417   pop   TOS
 418   urnext
 419 .done:
 420   add   ERP,4+4
 421   pop   TOS
 422   urnext
 423 endcode
 424 (arg-branch) (hidden)
 425
 426 code: (LOOP)  ( -- | limit counter )
 427   ;; ANS loops
 428   ;; this is faster version of "(+LOOP)"
 429   ;; most of the time we need jump address, so always load it
 430   ;; it also frees us from "add EIP,4" on exit
 431   lodsd
 432   add   dword [ERP],1
 433   jr    o,.done
 434   ;; next iteration
 435   mov   EIP,eax
 436   urnext
 437 .done:
 438   add   ERP,4+4
 439   urnext
 440 endcode
 441 (arg-branch) (hidden)
 442
 443
 444 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 445 ;; as i moved high-level compiler out of the core, we should do it there
 446 ;;alias "BREAK" cfa "LEAVE"
 447 ;;immediate
 448
 449 ;; removes loop arguments from return stack
 450 ;; can be used as: UNLOOP EXIT
 451 ;; "BREAK" compiles this word before branching out of the loop
 452 code: UNLOOP  ( | limit counter -- )
 453   add   ERP,4+4
 454   urnext
 455 endcode
 456
 457 code: I  ( -- counter )
 458   push  TOS
 459   ld    TOS,[ERP]
 460   sub   TOS,[ERP+4]
 461   urnext
 462 endcode
 463
 464 code: J  ( -- counter )
 465   push  TOS
 466   ld    TOS,[ERP+8]
 467   sub   TOS,[ERP+8+4]
 468   urnext
 469 endcode
 470
 471
 472 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 473 : TRUE   ( -- 1 )  state @ if compile lit-true else 1 endif ; immediate
 474 : FALSE  ( -- 0 )  state @ if compile lit-false else 0 endif ; immediate