level1/18_simple_malloc.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 ;; very simple, slow and wasteful memory allocator
   7 ;; DO NOT USE UNLESS REALLY NECESSARY!
   8
   9 : (simple-malloc-can-replace?)  ( -- flag )  true ; (hidden)
  10
  11 : (simple-malloc-align)  ( addr -- addr )  1- 4095 or 1+ ; (hidden)
  12
  13 ;; 0 is NOT valid!
  14 : (simple-malloc-valid-addr?)  ( addr -- flag )
  15   dup 4095 u> over 4095 and cell = and if (code-base-addr) dp-last-addr @ bounds? not
  16   else drop false endif
  17 ; (hidden)
  18
  19
  20 ;; get memory from the OS
  21 ;; WARNING! do not use this to allocate alot of small chunks!
  22 ;;          the granularity is 4096 bytes, so you will waste
  23 ;;          alot of memory this way!
  24 ;; first cell of the allocated memory is fill block size (cell+, aligned)
  25 ;; it is ok to allocate 0 bytes (it will return non-0 address that shold be freed)
  26 ;; returned value is always (aligned at 4096)+4
  27 ;; you can use "THROW" after malloc
  28 : simple-malloc  ( usize -- addr 0 // 0 throw-errcode )
  29   dup 0xffff_d000 u> if drop 0 err-out-of-memory
  30   else
  31     cell+ (simple-malloc-align) dup os:prot-r/w os:mmap
  32     if tuck ! cell+ 0 else 2drop 0 err-out-of-memory endif
  33   endif
  34 ;
  35
  36 ;; addr can be 0
  37 : simple-free  ( addr -- 0 // throw-errcode )
  38   dup if
  39     dup (simple-malloc-valid-addr?) if cell- dup @ os:munmap if err-invalid-malloc else 0 endif
  40     else drop err-invalid-malloc endif
  41   endif
  42 ;
  43
  44 ;; WARNING! rellocing to zero bytes WILL FREE memory! (and return 0 as newaddr)
  45 : simple-realloc  ( addr newsize -- newaddr 0 // addr throw-errcode )
  46   dup ifnot drop dup simple-free dup ifnot nip dup endif exit endif  ;; zero newsize
  47   over ifnot nip simple-malloc exit endif  ;; zero addr
  48   over (simple-malloc-valid-addr?) ifnot drop err-invalid-malloc exit endif
  49   dup 0xffff_d000 u> if drop err-out-of-memory exit endif
  50   cell+ (simple-malloc-align)  ;; align newsize
  51   2dup swap cell- @ = if drop 0  ;; nothing to do
  52   else over cell- dup @ rot dup >r os:mremap if nip r> over ! cell+ 0 else drop rdrop err-out-of-memory endif
  53   endif
  54 ;
  55
  56
  57 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  58 ;; memory allocation API
  59 ;; make sure that you will set it as soon as possible
  60 ;; the kernel is not using it, so it is safe to call kernel words
  61 ;; call "mman-can-replace?" before seting your own allocator
  62 ;; WARNING! not thread-safe (i.e. replace allocator BEFORE doing MT)
  63 ;;
  64 ;; high-level interface will make sure that the protocol is valid
  65 ;; i.e. won't call (mem-free) with zero size, will sort out calls
  66 ;; to (mem-realloc), and will never call (mem-alloc) with 0 size
  67 ;; it will also fix return values
  68 ;;
  69 ;; low-level memory manager words should not THROW
  70 ;;
  71
  72 $variable "(mem-can-replace?)" cfa "(simple-malloc-can-replace?)"  ;; ( -- flag )
  73 (hidden)
  74 ;; high-level API will never called this with zero size
  75 $variable "(mem-alloc)" cfa "simple-malloc"                        ;; ( usize -- addr 0 // garbage throw-errcode )
  76 (hidden)
  77 ;; high-level API will never called this with zero addr
  78 $variable "(mem-free)" cfa "simple-free"                           ;; ( addr -- 0 // throw-errcode )
  79 (hidden)
  80 ;; high-level API will never called this with zero addr or zero newsize
  81 $variable "(mem-realloc)" cfa "simple-realloc"                     ;; ( addr newsize -- newaddr 0 // garbage throw-errcode )
  82 (hidden)
  83
  84
  85 : mman-can-replace?  ( -- flag )  (mem-can-replace?) @execute-tail ;
  86
  87 ;; ANS/F2012
  88 ;; accepts 0, and allocates the smallest possible chunk in this case
  89 ;; returned addr is 0 on any error
  90 : allocate  ( size -- addr res )
  91   dup ifnot 1+ endif  ;; normalize size
  92   (mem-alloc) @execute
  93   dup if nip 0 swap endif  ;; normalize return addr
  94 ;
  95
  96 : free  ( addr -- res )  dup if (mem-free) @execute-tail endif ;
  97
  98 ;; frees on zero size, allocates on zero address
  99 ;; returns original addr on any error
 100 : resize  ( addr newsize -- newaddr 0 // addr throw-errcode )
 101   dup ifnot drop dup free dup ifnot nip dup endif exit endif  ;; zero newsize
 102   over ifnot nip allocate exit endif  ;; zero addr
 103   over >r (mem-realloc) @execute
 104   dup if nip r> swap else rdrop endif  ;; normalize return addr
 105 ;
 106
 107
 108 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 109 ;; use this when you need ASCIIZ string for various APIs
 110 ;; usage pattern:
 111 ;;  ensure-asciiz >r ... r> free-asciiz
 112 ;;
 113 : ensure-asciiz  ( addr count -- addr allocid )
 114   dup 1- -if 2drop NullString exit endif
 115   ;; check if it is 0-terminated
 116   2dup + c@ ifnot drop 0 exit endif
 117   dup 1+ allocate throw  ;; allocate temp buffer
 118   dup >r                 ;; save allocid
 119   2dup swap 1+ erase     ;; it is easier this way
 120   swap move r> dup       ;; copy and return the result
 121 ;
 122
 123 : free-asciiz  ( allocid -- )  free throw ;
 124