level1/17_dp.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 $constant "#dp-temp-sbuf" 8
   8
   9 : save-dp-temp  ( sbufaddr -- )
  10   (dp-temp-base) @ over ! cell+
  11   dp-temp @ swap !
  12 ;
  13
  14 : restore-dp-temp  ( sbufaddr -- )
  15   dup @ (dp-temp-base) ! cell+
  16   @ dp-temp !
  17 ;
  18
  19 : alloc-dp-temp  ( size -- addr )
  20   4096 max 4095 + -4096 and dup os:prot-rwx os:mmap err-out-of-memory not-?error
  21   swap cell- over !
  22 ;
  23
  24 : free-dp-temp  ( addr -- )
  25   ?dup if dup @ os:munmap err-out-of-memory ?error endif
  26 ;
  27
  28 ;; it should be allocated with "alloc-dp-temp"
  29 : setup-dp-temp  ( addr -- )
  30   dup (dp-temp-base) ! cell+ dp-temp !
  31 ;
  32
  33
  34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  35 ;; allocat dp-temp buffer if necessary, setup "dp-temp"
  36 : (setup-dp-temp)  ( -- )
  37   (dp-temp-buf) @ ?dup ifnot
  38     0 ( minimum size) alloc-dp-temp
  39     dup (dp-temp-buf) !
  40   endif
  41   setup-dp-temp
  42 ; (hidden)
  43
  44 : (dp-temp-size)  ( -- size )  (dp-temp-base) @ @ ; (hidden)
  45 : (dp-temp-end)  ( -- size )  (dp-temp-base) @ dup @ + ; (hidden)
  46
  47 : dp-temp-addr?  ( addr -- flag )  (dp-temp-base) @ dup if dup @ over + 1- bounds? else nip endif ;
  48 : dp-temp-reset  ( -- ) dp-temp 0! (dp-temp-base) 0! ;
  49
  50
  51 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  52 ;; allocate some memory at HERE (DP or DP-TEMP), return starting address
  53 : N-ALLOT  ( n -- start-addr )
  54   dup 0< err-negative-allot ?error
  55   dup 0x00ffffff u> err-out-of-memory ?error  ;; 16MB is quite huge allocation chunk ;-)
  56   (main-thread?) ERR-INVALID-THREAD not-?error
  57   dp-temp @ ?dup if  ;; allocate in dp-temp  ( n dpaddr )
  58     over (dp-temp-size) u>= err-out-of-memory ?error
  59     2dup + 128 + (dp-temp-end) u>= err-out-of-memory ?error
  60     swap dp-temp +!
  61   else  ;; allocate in normal dictionary
  62     dp @ 2dup + dp-last-addr @ 512 - u> err-out-of-memory ?error
  63     swap dp +!
  64   endif
  65 ;
  66
  67 : check-align-here  ( -- )
  68   here 3 and err-align-violation ?error
  69 ;
  70
  71 : align-here  ( -- )
  72   here 3 and ?dup if 4 swap - dup n-allot swap erase endif
  73 ;
  74
  75 : ALLOT  ( n -- )  n-allot drop ;
  76
  77 : USED  ( -- count )  dp @ (code-base-addr) - ;
  78 : UNUSED  ( -- count )  dp-last-addr @ dp @ - 512 - 0 max ;  \ with some safety margin
  79
  80 : REAL-HERE  ( -- addr )  dp @ ;
  81
  82 code: HERE  ( -- addr )
  83   push  TOS
  84   ld    TOS,[pfa "dp-temp"]
  85   or    TOS,TOS
  86   cmovz TOS,[pfa "dp"]
  87   urnext
  88 endcode
  89
  90
  91 : (dp-protected?)  ( addr -- flag )
  92   (code-base-addr) dp-protected @ 1- bounds?
  93 ; (hidden)
  94
  95 ;; "addr" is first unprotected addr
  96 : (dp-protect)  ( addr -- )
  97   dp-protected @ umax dp-protected !
  98 ; (hidden)
  99
 100 : (dp-protect-cfa)  ( cfa -- )
 101   dup cfa-wsize + (dp-protect)
 102 ; (hidden)
 103
 104
 105 ;; pad is uservar
 106 : PAD  ( -- addr )  pad-area @ ;
 107
 108 ;; new thread has no pad
 109 : pad-allocate  ( -- )
 110   pad ifnot
 111     #pad-area-resv #pad-area +
 112     os:get-pid os:get-tid = if
 113       ;; main thread
 114       brk-alloc
 115     else
 116       os:prot-r/w os:mmap ERR-OUT-OF-MEMORY not-?error
 117     endif
 118     #pad-area-resv + pad-area ! pad 1- (hld) !
 119   endif
 120 ;
 121
 122 ;; should be called when thread exits
 123 : pad-deallocate  ( -- )
 124   pad if
 125     os:get-pid os:get-tid = if
 126       pad-area @ #pad-area-resv -  #pad-area-resv #pad-area + os:munmap drop
 127       pad-area 0! (hld) 0!
 128     endif
 129   endif
 130 ;
 131
 132
 133 : C,  ( c -- )
 134  $if URFORTH_DEBUG
 135   (dbginfo-add-here)
 136  $endif
 137   1 n-allot c!
 138 ;
 139
 140 : W,  ( w -- )
 141  $if URFORTH_DEBUG
 142   (dbginfo-add-here)
 143 $endif
 144   2 n-allot w!
 145 ;
 146
 147 : ,  ( n -- )
 148  $if URFORTH_DEBUG
 149   (dbginfo-add-here)
 150 $endif
 151   cell n-allot !
 152 ;
 153
 154 ;; create a relocation for the given addr
 155 : (rel-create)  ( addr -- )
 156   (code-base-addr) here 1- bounds? err-bad-reladdr not-?error
 157 ; (hidden)
 158
 159 ;; this can be customized for special builds
 160 ;; use this instead of "," to compile address that needs a relocation
 161 : reladdr,  ( addr -- )
 162   ( dup if) dup (code-base-addr) here 32767 + bounds? ( dup ifnot dbg endif) err-bad-reladdr not-?error ( endif)
 163   here swap , (rel-create)
 164 ;