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