level1/15_rstack.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 code: RP@  ( -- rp )
   8   push  TOS
   9   mov   TOS,ERP
  10   urnext
  11 endcode
  12
  13 code: RP!  ( n -- )
  14   mov   ERP,TOS
  15   pop   TOS
  16   urnext
  17 endcode
  18
  19 code: RP0!  ( -- )
  20   mov   ERP,ts:[ua_ofs_rp0]
  21   urnext
  22 endcode
  23
  24
  25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26 code: RDUP  ( -- | n -- n n )
  27   peekr eax
  28   pushr eax
  29   urnext
  30 endcode
  31
  32 code: RDROP ( -- | n -- )
  33   dropr
  34   urnext
  35 endcode
  36
  37 code: >R  ( n -- | -- n )
  38   pushr TOS
  39   pop   TOS
  40   urnext
  41 endcode
  42
  43 code: R>  ( -- n | n -- )
  44   push  TOS
  45   popr  TOS
  46   urnext
  47 endcode
  48
  49 code: R@  ( -- n | n -- n )
  50   push  TOS
  51   peekr TOS
  52   urnext
  53 endcode
  54
  55
  56 code: 2RDROP  ( -- | n0 n1 -- )
  57   add   ERP,4*2
  58   urnext
  59 endcode
  60
  61 code: 2>R  ( n0 n1 -- | -- n0 n1 )
  62   pop   eax   ;; n0
  63   pushr eax
  64   pushr TOS
  65   pop   TOS
  66   urnext
  67 endcode
  68
  69 code: 2R>  ( -- n0 n1 | n0 n1 -- )
  70   push  TOS
  71   popr  TOS
  72   popr  eax
  73   push  eax
  74   urnext
  75 endcode
  76
  77 code: 2R@  ( -- n0 n1 | n0 n1 )
  78   push  TOS
  79   push  dword [ERP+4]
  80   mov   TOS,dword [ERP]
  81   urnext
  82 endcode
  83
  84
  85 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  86 code: RDEPTH  ( -- rstack-depth-before-this-call )
  87   push  TOS
  88   ld    TOS,ts:[ua_ofs_rp0]
  89   sub   TOS,ERP
  90   sar   TOS,2
  91   urnext
  92 endcode
  93
  94
  95 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  96 ;; remove idx, copy item from return stack; 0 RPICK is the same as R@
  97 code: RPICK  ( idx -- n[rtop-idx-1] )
  98   ld    TOS,[ERP+TOS*4]
  99   urnext
 100 endcode
 101
 102 alias RPICK RPEEK
 103
 104 ;; remove idx and val, set nth item (numbered as in RPICK)
 105 code: RPOKE  ( val idx -- )
 106   pop   eax
 107   ld    [ERP+TOS*4],eax
 108   pop   TOS
 109   urnext
 110 endcode
 111
 112
 113 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 114 code: NRDROP ( cells -- )
 115   lea   ERP,[ERP+TOS*4]
 116   pop   TOS
 117   urnext
 118 endcode
 119
 120
 121 code: RALLOCA  ( bytes -- addr )
 122   add   TOS,3
 123   and   TOS,-4
 124   sub   ERP,TOS
 125   ld    TOS,ERP
 126   urnext
 127 endcode
 128
 129 code: RDEALLOCA  ( bytes -- )
 130   add   TOS,3
 131   and   TOS,-4
 132   add   ERP,TOS
 133   pop   TOS
 134   urnext
 135 endcode
 136
 137
 138 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 139 ;; local variables support code
 140 ;; it can be implemented without asm (and "libs/locals.f" contains such implementation),
 141 ;; but i moved it here for speed reasons
 142 ;;
 143
 144 ;; locals frame:
 145 ;;   ...locals
 146 ;;   dd prevlocptr  -- locptr points here
 147
 148 code: free-local-frame  ( -- )
 149   ld    eax,ts:[ua_ofs_locptr]
 150   ld    edx,[eax]    ;; prevlocptr
 151   ld    ts:[ua_ofs_locptr],edx
 152   lea   ERP,[eax+4]  ;; drop local frame
 153   urnext
 154 endcode
 155 (* reference implementation:
 156 : free-local-frame  ( -- )  (locptr@) dup @ (locptr!) cell+ r> swap rp! >r ;
 157 *)
 158
 159
 160 ;; allocate local frame on rstack, copy args, zero uncopied slots
 161 ;; totalcells should include one cell for prevlocptr
 162 code: alloc-local-frame  ( argcells totalcells -- )
 163   lea   edx,[ERP-4]  ;; new locptr
 164   lea   eax,[TOS*4]
 165   sub   ERP,eax
 166   ;; fix prevlocptr
 167   ld    eax,ts:[ua_ofs_locptr]
 168   ld    [edx],eax    ;; set prevlocptr
 169   ld    ts:[ua_ofs_locptr],edx
 170   ;; clear unused part
 171   ld    edi,ERP
 172   pop   edx  ;; argcells
 173   stc
 174   sbb   ecx,edx
 175   jr    z,.noclear
 176   xor   eax,eax
 177   rep stosd
 178 .noclear:
 179   ld    ecx,edx
 180   jecxz .done
 181   ld    edx,EIP
 182   ld    esi,esp
 183   lea   esp,[esp+ecx*4]
 184   rep movsd
 185   ld    EIP,edx
 186 .done:
 187   pop   TOS
 188   urnext
 189 endcode
 190 (* reference implementation:
 191 : alloc-local-frame  ( argcells totalcells -- )
 192   ac tc newlocptr
 193   rp@ r> 2over ralloca 2drop >r
 194   (locptr@) over ! dup (locptr!)
 195   cells erase
 196   ;; copy args
 197   ?dup if >r sp@ (locptr@) r@ 1- cells dup swap - swap cmove r> dealloca endif
 198 ;
 199 *)
 200
 201
 202 code: (local-addr)  ( cellofs -- addr )
 203   ld    eax,ts:[ua_ofs_locptr]
 204   neg   TOS
 205   lea   TOS,[eax+TOS*4]
 206   urnext
 207 endcode
 208
 209 code: (local-load)  ( cellofs -- value )
 210   ld    eax,ts:[ua_ofs_locptr]
 211   neg   TOS
 212   lea   TOS,[eax+TOS*4]
 213   ld    TOS,[TOS]
 214   urnext
 215 endcode