libs/mini-threads.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 use-libs: asm os-errno
   7
   8 (*
   9   note that new thread has pad, but not tib. it means that you cannot use tib
  10   for input.
  11   also, don't try to compile code, or TLOAD files: those things won't work.
  12 *)
  13
  14 vocabulary thread
  15 also thread definitions
  16
  17
  18 : (trd-die)  ( code -- )
  19   \ endcr ." exiting from the thread " os:get-tid . cr
  20   >r ['] forth:(thread-cleanup) catch
  21   pad-deallocate
  22   \ pad-allocate endcr ." !!!: " (pad-tres) @ . cr
  23   ;; free pad
  24   ;;pad-area @ ?dup if pad-area #pad-area-resv - #pad-area-resv #pad-area + os:munmap . cr endif
  25   r> os:(trd-exit)
  26 ;
  27 (hidden)
  28
  29
  30 : trd-abort-cleanup  ( -- )
  31   ERR-USER-ERROR (trd-die)
  32 ;
  33
  34 : trd-error-cleanup  ( code -- )
  35   (trd-die)
  36 ;
  37
  38
  39 : (thread-starter)  ( cfa -- )
  40   rp0! >r sp0!
  41   fpu-reset
  42   ['] trd-abort-cleanup (abort-cleanup-ptr) !
  43   ['] trd-abort-cleanup (abort-ptr) !
  44   ['] trd-error-cleanup (error-ptr) !
  45   ['] trd-error-cleanup (fatal-error-ptr) !
  46   pad-allocate
  47   forth:(thread-init)
  48   \ ." starting thread...\n"
  49   r> execute
  50   0 (trd-die)
  51 ;
  52
  53 : (tls-sp0!)  ( value baseaddr -- sp0 )  ['] sp0 uservar-@ofs + ! ;
  54 : (tls-rp0!)  ( value baseaddr -- rp0 )  ['] rp0 uservar-@ofs + ! ;
  55 : (tls-#sp!)  ( value baseaddr -- sp0 )  ['] #sp uservar-@ofs + ! ;
  56 : (tls-#rp!)  ( value baseaddr -- rp0 )  ['] #rp uservar-@ofs + ! ;
  57 : (tls-size!)  ( value baseaddr -- size )  ['] forth:(user-full-size) uservar-@ofs + ! ;
  58 : (tls-addr!)  ( value baseaddr -- size )  ['] forth:(user-base-addr) uservar-@ofs + ! ;
  59
  60 : (tls-sp0@)  ( baseaddr -- sp0 )  ['] sp0 uservar-@ofs + @ ;
  61 : (tls-rp0@)  ( baseaddr -- rp0 )  ['] rp0 uservar-@ofs + @ ;
  62 : (tls-size@)  ( baseaddr -- size )  ['] forth:(user-full-size) uservar-@ofs + @ ;
  63
  64
  65 ;; this will allocate userarea and stacks for a new thread
  66 ;; it will also copy userarea defaults, set addresses, stack sizes, and stack pointers
  67 : (alloc-tls)  ( dsize rsize -- baseaddr )
  68   ;; for simplicity, we will copy the whole user area, even if it isn't wholly used
  69   2dup cells swap cells + 8 +cells forth:(user-area-max-size) + dup >r  ;; ( dsize rsize bytes | bytes )
  70   os:prot-r/w os:mmap not-?abort" cannot allocate thread memory"
  71   r> swap dup >r
  72   ;; init with default user area
  73   forth:(user-area-default) r@ forth:(user-area-max-size) 0 max cmove
  74   ;; setup basic tls params
  75   (tls-size!)
  76   r@ r@ (tls-addr!)
  77   ;; setup stack sizes
  78   over r@ (tls-#sp!)
  79   r@ (tls-#rp!)
  80   ;; setup stack pointers
  81   r@ (tls-size@) 4 -cells r@ + dup r@ (tls-sp0!)
  82   swap cells - r@ (tls-rp0!)
  83   r>
  84 ;
  85
  86 ;; this will be factored to "spawn-ex" later
  87 : spawn  ( cfa -- tid )
  88   ;; allocate memory for userarea and stacks
  89   forth:(user-area-default) ['] #sp uservar-@ofs + @
  90   forth:(user-area-default) ['] #rp uservar-@ofs + @
  91   (alloc-tls) >r
  92   ;; thread stack contains cfa and user-defined data (cfa is first to pop)
  93   r@ (tls-sp0@) cell- !
  94   0x29a r@ (tls-sp0@) !  ;; udata
  95   ['] (thread-starter)
  96   ;; prepare other clone args
  97   r@ (tls-sp0@) r@ (tls-rp0@)
  98   [ 0
  99     \ os:CLONE-CHILD-CLEARTID or
 100     \ os:CLONE-CHILD-SETTID or
 101     os:CLONE-DETACHED or ;; pure and useless compatibility flag that does nothing
 102     os:CLONE-FILES or
 103     os:CLONE-FS or
 104     os:CLONE-IO or
 105     os:CLONE-PARENT-SETTID or
 106     os:CLONE-SETTLS or
 107     os:CLONE-SIGHAND or
 108     os:CLONE-SYSVSEM or
 109     os:CLONE-THREAD or
 110     os:CLONE-VM or
 111   ] literal
 112   ;; create TLS descriptor
 113   r> 16 ralloca swap >r dup
 114   forth:(user-tls-entry-index) over ! cell+  ;; entry index
 115   r@ over ! cell+           ;; base address
 116   r@ (tls-size@) 4095 + 12 rshift over ! cell+  ;; limit in pages
 117   0b1_0_1_0_00_1 swap !     ;; flags
 118   0 0 ;; no tid ptrs
 119   os:clone
 120   r> 16 rdealloca >r
 121   dup 0xffff_f000 u>= if
 122     ;; error
 123     os:errno-name type cr bye
 124     r> dup (tls-size@) os:munmap drop
 125     abort" cannot create thread!"
 126   endif
 127   rdrop
 128 ;
 129
 130
 131 previous definitions