meta/meta-60-asm-commands.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 ;; additional assembler commands
   8 ;; WARNING! there should be NO argument-less asm commands
   9 ;;          they will break the parser!
  10 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  11
  12 ;; app entry point
  13 : $ENTRY  ( -- )
  14   Reset-Instruction
  15   4 to *OpSize
  16   Imm
  17   ;; label?
  18   *Imm elf-entry-point-addr !
  19   *OpReloc if
  20     *ImSize 4 = ERRID_ASM_EXPECT_32BIT_OPERAND not-?asm-error
  21     *ImmName ccount *ImSize *ImmForthType
  22     ;; HACK!
  23     elf-current-pc >r
  24     elf-entry-point-addr real->tc to elf-current-pc
  25     asm-Label-Fixup
  26     r> to elf-current-pc
  27   endif
  28 ;
  29
  30 : $ALIGN  ( -- )  macro-instrs:align ;
  31
  32
  33 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34 : ($VAR-ETC-CREATE)  ( tc-cfa -- )
  35   ;; get name
  36   tk-str? ERRID_ASM_STRING_EXPECTED not-?asm-error
  37   ;; create word header and CFA
  38   lexer:tkvalue count 2dup upcase-str rot execute
  39   lexer:NextToken
  40 ; (hidden)
  41
  42 : ($VAR-COMPILE-VALUE)  ( -- )
  43   ;; parse word value
  44   Reset-Instruction
  45   4 to *OpSize
  46   Imm
  47   ;; label?
  48   *OpReloc if
  49     ;; create label fixup
  50     *ImSize 4 = ERRID_ASM_EXPECT_32BIT_OPERAND not-?asm-error
  51     *ImmName ccount *ImSize *ImmForthType asm-Label-Fixup
  52   endif
  53   ;; put value
  54   *Imm tc-,
  55   tc-create;
  56 ; (hidden)
  57
  58 : ($VAR-ETC)  ( tc-cfa -- )
  59   ($VAR-ETC-CREATE)
  60   ($VAR-COMPILE-VALUE)
  61 ; (hidden)
  62
  63 ;; this one doesn't take a value
  64 : $DVAR         ( -- )  ['] tc-(variable-header-str) ($VAR-ETC-CREATE) 0 tc-, 0 tc-, tc-create; ;
  65
  66 : $VARIABLE     ( -- )  ['] tc-(variable-header-str) ($VAR-ETC) ;
  67 : $CONSTANT     ( -- )  ['] tc-(constant-header-str) ($VAR-ETC) ;
  68 : $VALUE        ( -- )  ['] tc-(value-header-str) ($VAR-ETC) ;
  69 : $DEFER        ( -- )  ['] tc-(defer-header-str) ($VAR-ETC) ;
  70
  71 : $USERVAR  ( -- )
  72   tc-tls-type tc-tls-fs = if
  73     4 ['] tc-(uservar-header-str) ($VAR-ETC-CREATE)
  74     ;; create offset constant
  75     tk-id? ERRID_ASM_LABEL_EXPECTED not-?asm-error
  76     dup lexer:tkvalue count rot asmx86:asm-Make-Label
  77     lexer:NextToken
  78     ;; parse value
  79     Reset-Instruction
  80     4 to *OpSize
  81     Imm
  82     ;; label?
  83     *OpReloc if
  84       ;; create label fixup
  85       *ImSize 4 = ERRID_ASM_EXPECT_32BIT_OPERAND not-?asm-error
  86       ;; hack!
  87       asmx86:asm-PC >r dup to elf-current-pc
  88       *ImmName ccount *ImSize *ImmForthType asm-Label-Fixup
  89       r> to elf-current-pc
  90     endif
  91     ;; put value
  92     *Imm swap tc-get-ua-rva tc-!
  93     tc-create;
  94   else
  95     ['] tc-(variable-header-str) ($VAR-ETC-CREATE)
  96     ;; create offset constant
  97     tk-id? ERRID_ASM_LABEL_EXPECTED not-?asm-error
  98     lexer:tkvalue count asmx86:asm-PC asmx86:asm-Make-Label
  99     lexer:NextToken
 100     ($VAR-COMPILE-VALUE)
 101   endif
 102 ;
 103
 104 : $ALLOT  ( -- )
 105   ;; parse word value
 106   Reset-Instruction
 107   4 to *OpSize
 108   Imm
 109   ;; label?
 110   *OpReloc ?abort" cannot use labels in $allot"
 111   *Imm tc-n-allot drop
 112 ;
 113
 114 : $USERALLOT  ( -- )
 115   ;; parse word value
 116   Reset-Instruction
 117   4 to *OpSize
 118   Imm
 119   ;; label?
 120   *OpReloc ?abort" cannot use labels in $userallot"
 121   *Imm
 122   tc-tls-type tc-tls-fs = if
 123     tc-(userval-allot)
 124   else
 125     tc-n-allot drop
 126   endif
 127 ;
 128
 129
 130 : $VOCABHEADER  ( -- )
 131   ['] tc-(vocab-header-str) ($VAR-ETC)
 132   tc-create;
 133   ;; patch wordlist name pointer
 134   *OpReloc if *ImmLabelDefined else true endif
 135   if
 136     ;; address is known, fix name pointer
 137     tc-latest-nfa
 138     \ tc-here cell- tc-@  ;; get wordlist address
 139     *Imm                  ;; our wordlist address lives here too ;-)
 140     tc-vocid->headnfa
 141     ;; sanity check
 142     dup tc-@ ?abort" trying to create two headers for one wordlist"
 143     tc-!
 144   else
 145     ;; address is unknown
 146     ?abort" cannot create vocabulary headers with forwards (yet)"
 147   endif
 148 ;
 149
 150
 151 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 152 -1 value tc-has-debugger?  (hidden)
 153 0 value tc-urforth-next-ptr  (hidden)
 154
 155 : (ur-has-dbg?)  ( -- flag )
 156   tc-has-debugger? -if
 157     " URFORTH_DEBUG" asmx86:asm-Get-Constant if
 158       notnot to tc-has-debugger?
 159       tc-has-debugger? if
 160         \ " urforth_next_ptr" asmx86:asm-Get-Label 1 <> ?abort" \`urforth_next_ptr\` must be defined"
 161         " urforth_next" asmx86:asm-Get-Label 1 <> ?abort" \`urforth_next\` must be defined"
 162         to tc-urforth-next-ptr
 163       endif
 164     endif
 165   endif
 166   tc-has-debugger?
 167 ; (hidden)
 168
 169
 170 : tc-NEXT  ( -- )
 171   \ " lodsd" asm-str
 172   $AD asm-c,
 173   \ old: either "jmp eax" of "jmp dword [nextref]"
 174   \ new: either "jmp eax" of "jmp tc-urforth-next-ptr"
 175   (ur-has-dbg?) +if
 176     \ $FF asm-c,
 177     \ $25 asm-c, tc-urforth-next-ptr asm-,
 178     $E9 asm-c, tc-urforth-next-ptr asm-pc 4+ - asm-,
 179   else
 180     $E0FF asm-w,
 181   endif
 182 ; (hidden)
 183
 184 replace asmx86:macro-instrs:NEXT tc-NEXT