level1/03_do_codeblocks.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 ;; aligned PFA forces aligned CFA (metacompiler does this)
   8
   9 code: (URFORTH-DOXXX-CODEBLOCKS)
  10   align 16,$90
  11 ur_doforth:
  12   pushr EIP
  13   pop   EIP
  14   $if URFORTH_ALIGN_PFA
  15   add   EIP,3
  16   $endif
  17   urnext
  18
  19   align 16,$90
  20 ur_doconst:
  21   xchg  TOS,[esp]
  22   $if URFORTH_ALIGN_PFA
  23   add   TOS,3
  24   $endif
  25   mov   TOS,[TOS]
  26   urnext
  27
  28   align 16,$90
  29 ur_dovar:
  30   xchg  TOS,[esp]
  31   $if URFORTH_ALIGN_PFA
  32   add   TOS,3
  33   $endif
  34   urnext
  35
  36   align 16,$90
  37 ur_dovalue:
  38   xchg  TOS,[esp]
  39   $if URFORTH_ALIGN_PFA
  40   add   TOS,3
  41   $endif
  42   mov   TOS,[TOS]
  43   urnext
  44
  45   align 16,$90
  46 ur_dodefer:
  47   pop   eax
  48   $if URFORTH_ALIGN_PFA
  49   add   eax,3
  50   $endif
  51   mov   eax,[eax]
  52   jp    eax
  53
  54   align 16,$90
  55 ur_dodoes:
  56   ;; pfa is on the stack
  57   ;; EAX is new VM IP
  58   xchg  TOS,[esp]
  59   pushr EIP
  60   $if URFORTH_ALIGN_PFA
  61   add   TOS,3
  62   $endif
  63   mov   EIP,eax
  64   urnext
  65
  66   align 16,$90
  67 ur_dooverride:
  68   pushr EIP
  69   pop   EIP
  70   $if URFORTH_ALIGN_PFA
  71   add   EIP,3
  72   $endif
  73   xchg  TOS,[esp]
  74   $if URFORTH_ALIGN_PFA
  75   add   TOS,3
  76   $endif
  77   urnext
  78
  79   align 16,$90
  80 ur_douservar:
  81   xchg  TOS,[esp]
  82   $if URFORTH_ALIGN_PFA
  83   add   TOS,3
  84   $endif
  85  $if URFORTH_TLS_TYPE = URFORTH_TLS_TYPE_FS
  86   ld    TOS,[TOS]   ;; offset
  87   add   TOS,ts:[0]  ;; add user area base address
  88  $endif
  89   urnext
  90
  91 ;; use this subroutine to call a forth word from a machine code
  92 ;; EAX should point to the cfa
  93 ;; TOS and other things should be set accordingly
  94 ;; direction flag should be cleared
  95 ;; no registers are preserved
  96   align 16,$90
  97 ur_mc_fcall:
  98   ;; move mc return address to rstack
  99   pop   edx
 100   pushr edx
 101   ;; push current EIP to rstack
 102   pushr EIP
 103   ;; set new EIP
 104   mov   EIP,.justexit
 105
 106   ;; turn off debugger temporarily, because the debugger is using this
 107   $if URFORTH_DEBUG
 108   ld    edx,[urfdebug_active_flag]
 109   pushr edx
 110   ;; special flag, means "no breakpoint checks"
 111   ld    dword [urfdebug_active_flag],-1
 112   $endif
 113
 114   ;; and execute the word
 115   jp    eax
 116 .justexit:
 117   dd  .fakeret_code
 118 .fakeret_code:
 119   ;; restore debugger state
 120   $if URFORTH_DEBUG
 121   popr  edx
 122   ld    dword [urfdebug_active_flag],edx
 123   $endif
 124
 125   ;; restore EIP
 126   popr  EIP
 127   ;; restore return address
 128   popr  eax
 129   ;; and jump there
 130   jp    eax
 131 endcode
 132 (hidden) (codeblock)
 133
 134
 135 $constant "(URFORTH-DOFORTH-ADDR)" ur_doforth
 136 $constant "(URFORTH-DOCONST-ADDR)" ur_doconst
 137 $constant "(URFORTH-DOVAR-ADDR)" ur_dovar
 138 $constant "(URFORTH-DOVALUE-ADDR)" ur_dovalue
 139 $constant "(URFORTH-DODEFER-ADDR)" ur_dodefer
 140 $constant "(URFORTH-DODOES-ADDR)" ur_dodoes
 141 $constant "(URFORTH-DOOVERRIDE-ADDR)" ur_dooverride
 142 $constant "(URFORTH-DOUSERVAR-ADDR)" ur_douservar
 143 $constant "(URFORTH-FCALL-ADDR)" ur_mc_fcall