level0/urforth0_w_temp_pool.asm

   1 ;; Native x86 GNU/Linux Forth System, Direct Threaded Code
   2 ;;
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;;
   5 ;; This program is free software: you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation, version 3 of the License ONLY.
   8 ;;
   9 ;; This program is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;; GNU General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU General Public License
  15 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  16
  17
  18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  19 ;; very simple pool allocator for temporary data
  20 ;; allocates bytes from the end of the memory
  21 urword_var "(TEMP-POOL-TOP)",temp_pool_top,0
  22 urword_hidden
  23 urword_const "(TEMP-POOL-BOT-OFS)",temp_pool_bot_ofs,1024
  24 urword_hidden
  25
  26 urword_forth "TEMP-POOL-RESET",temp_pool_reset
  27 ;; ( -- )
  28 ;; resets temporary pool (i.e. deallocates everything)
  29   UF dpend @ temp_pool_bot_ofs - temp_pool_top !
  30 urword_end
  31
  32 urword_forth "TEMP-POOL-MARK",temp_pool_mark
  33 ;; ( -- addr )
  34 ;; returns temp pool "mark", which can be used in "TEMP-POOL-RELEASE"
  35   UF temp_pool_top @
  36 urword_end
  37
  38 urword_forth "TEMP-POOL-HERE",temp_pool_here
  39 ;; ( -- addr )
  40 ;; returns temp pool "here", i.e. current top
  41 ;; can be used to avoid keeping it elsewhere
  42   UF temp_pool_top @
  43 urword_end
  44
  45 urword_forth "TEMP-POOL-RELEASE",temp_pool_release
  46 ;; ( addr -- )
  47 ;; deallocates temp pool bytes
  48 ;; aborts on invalid mark values
  49   ; trying to allocate something instead of freeing it?
  50   UF dup temp_pool_top @ uless errid_invalid_temp_pool_release qerror
  51   ; trying to go beyound the end of the pool?
  52   UF dup dpend @ temp_pool_bot_ofs - ugreat
  53   UF errid_invalid_temp_pool_release qerror
  54   ; set this as new pool top
  55   UF temp_pool_top !
  56 urword_end
  57
  58 urword_forth "TEMP-POOL-ALLOC",temp_pool_alloc
  59 ;; ( size -- addr )
  60 ;; deallocates temp pool bytes
  61 ;; aborts on invalid mark values
  62   ; sanity check for size
  63   UF dup 0 less errid_invalid_temp_pool_allocation qerror
  64   UF dup unused great errid_invalid_temp_pool_allocation qerror
  65   ; check if we'll have less than 64KB of room between the temp pool and HERE
  66   UF dup here + 65536 + temp_pool_top @ ugreat errid_out_of_temp_pool qerror
  67   ; allocate
  68   UF temp_pool_top subpoke
  69   ; return the address of the allocated memory
  70   UF temp_pool_here
  71 urword_end
  72
  73 ; for code words
  74
  75 urword_code "(NO-CALL-TEMP-POOL-CODESUBS)",par_no_call_temp_pool_subs
  76 urword_hidden
  77 urword_codeblock
  78 ;; OUT: EAX=mark
  79 ;; other registers are preserved (except flags)
  80 urpool_mark:
  81   ld    eax,[fvar_temp_pool_top_data]
  82   ret
  83
  84 ;; IN: EAX=mark
  85 ;; OUT: nothing
  86 ;; all registers are preserved (except flags)
  87 ;; TODO: sanity checks
  88 urpool_release:
  89   ld    [fvar_temp_pool_top_data],eax
  90   ret
  91
  92 ;; IN: EAX=size
  93 ;; OUT: EDI=address
  94 ;; all other registers (including EAX) are preserved (except flags)
  95 ;; TODO: sanity checks
  96 urpool_alloc:
  97   ld    edi,[fvar_temp_pool_top_data]
  98   sub   edi,eax
  99   jr    c,urpool_alloc_error
 100   cmp   edi,[fvar_temp_pool_top_data]
 101   jr    nc,urpool_alloc_error
 102   ld    eax,[fvar_dp_temp_data]
 103   or    eax,eax
 104   cmovz eax,[fvar_dp_data]
 105   add   eax,65536
 106   cmp   edi,eax
 107   jr    c,urpool_alloc_error
 108   ; success
 109   ld    [fvar_temp_pool_top_data],edi
 110   ret
 111
 112 urpool_alloc_error:
 113   ld    TOS,ERR_OUT_OF_TEMP_POOL
 114   ld    eax,fword_error
 115   call  ur_mc_fcall
 116   ; it will never return
 117 urword_end