Multihtreading in SP-Forth/2 spf2.5.15

mtask.f

\ 24.Nov.2001 Sat 16:29
\ coprocesses

REQUIRE JMP lib\jmp.f  \ for interception old HANDLER
REQUIRE CELL-  lib\cells.f
REQUIRE ?FREED lib\cells.f
REQUIRE TicksCount lib\ticks.F
REQUIRE DOS_key_buf_head lib\key_q.f

( корпоративная многопоточность
  /round-robin/
)

MODULE: MTASK_Support

EXPORT

 20 VALUE T-MAXCOUNT

  50 CELLS VALUE /PStack
  50 CELLS VALUE /RStack
 512 CELLS VALUE /USER-AREA

DEFINITIONS

0 VALUE U0 ( -- user-a )

0
1 CELLS -- ^prev
1 CELLS -- ^next
1 CELLS -- ^TState
1 CELLS -- ^pstack
1 CELLS -- ^rstack
1 CELLS -- ^RP
1 CELLS -- ^SP
1 CELLS -- ^SS
1 CELLS -- ^tls
1 CELLS -- ^xt
1 CELLS -- ^Ticks
CONSTANT /TaskHdr

: /TLS ( -- u )
  /USER-AREA
  /TaskHdr +
;

0 VALUE t-next

: JmpTask  ( tid -- ) \ возврат в точку после JmpTask, в след. проходе по кольцу
  DUP TO t-next U0 = IF EXIT THEN
  GET-SS-SP-RP
  U0 ^RP !      U0 ^SP !      U0 ^SS !
  t-next ^SS @  t-next ^SP @  t-next ^RP @
  t-next TO U0
  SET-SS-SP-RP
;

VARIABLE USER-OFFS \ смещение в области данных потока, 
                   \ где создаются новые переменные
/TaskHdr USER-OFFS !

VARIABLE T-COUNT  T-COUNT 0! \ число потоков

EXPORT

: USER-ALLOT ( n -- )
  USER-OFFS +!
  USER-OFFS @ /TLS > IF -550 THROW THEN
;
: USER-HERE ( -- n )
  USER-OFFS @
;
: USER-CREATE ( "<spaces>name" -- )
  CREATE
  USER-HERE ,
  DOES> @ U0 +
;
: USER ( "<spaces>name" -- ) \ локальные переменные потока
  USER-CREATE
  1 CELLS USER-ALLOT
;

\ ========================================
: USER-INIT ( -- ) ... ;
: USER-EXIT ( -- ) ... ;

: THREADS ( -- n ) T-COUNT @ ;

\ ========================================

DEFINITIONS

0 VALUE _t

: Ring+ ( tid -- tid ) \ перед текущей.
 U0 IF
  TO _t
  U0 ^prev @ _t ^prev !
  U0 _t ^next !
  _t _t ^prev @ ^next !
  _t U0 ^prev !  _t
 ELSE
  DUP TO U0
 THEN T-COUNT 1+!
;
: Ring- ( tid -- tid )
  TO _t
  _t ^prev @
  _t ^next @ ^prev !
  _t ^next @
  _t ^prev @ ^next !
  _t
  -1 T-COUNT +!
;

: (STOP) ( tid -- )  \ not for self !
  Ring-
  DUP ^pstack ?FREED
  DUP ^rstack ?FREED
  FREE THROW
;

: AtSuspend ( tid -- tid1 )
  ^next @  DUP ^xt @ >R
;
: AtRun ( tid -- )
  JmpTask
;
: AtStop ( tid -- )
  \ DUP . ." Stoped "
  DUP ^next @  DUP ^xt @ >R
  SWAP (STOP)
;

: AllocTLS ( -- tls ) \ and binding
  /TLS     ALLOCATE THROW  DUP /TLS ERASE  DUP >R ( a )
  DUP R@ ^next !
  DUP R@ ^prev !
  R@ ^tls !
  R>
;
( SP@ дает адрес занятой ячейки стека)

: BuildTLS ( -- tls )
  AllocTLS >R
  DS@ R@ ^SS !  \ память для стеков в DS
  /PStack  ALLOCATE THROW DUP R@ ^pstack !
  /PStack + CELL- CELL- R@ ^SP !
  /RStack  ALLOCATE THROW DUP R@ ^rstack !
  /RStack + CELL- CELL- R@ ^RP !
  ['] JmpTask R@ ^xt !
  R>
;

: BuildMainTLS ( -- tls )
  AllocTLS >R
  ['] JmpTask R@ ^xt !
  R>
;

USER NEW-HANDLER

\ ==========================================

: T-NEXT ( -- tid ) \ дать следующий tid
  U0 ^next @
;

EXPORT

S" lib\mtask_a.f" INCLUDED

: INIT-MTASK ( -- )
  T-COUNT @ 0= IF
  BuildMainTLS TO U0
  T-COUNT 1+!
  S0_OLD @ S0 !  \ ***
  HANDLER @ NEW-HANDLER !
  ['] NEW-HANDLER ['] HANDLER
  JMP          THEN
;

..: AT-PROCESS-STARTING T-COUNT 0! INIT-MTASK ;..

: NEXT-T ( -- ) \ перейти к следующей (отдать управление)
  \ U0 . ." NEXT-T "
  \ U0 IF
   U0 ^next @
   DUP ^xt @ >R
  \ THEN
;
: T-SELF ( -- tid ) U0 ;

: START ( x task -- tid )
  BuildTLS >R
  R@ ^RP @ !
  R@ ^SP @ !
  0 R@ ^TState !
  R> Ring+ 
;
: STOP ( tid -- )  \ not for self !
  (STOP)
;
: TERMINATE ( -- )
  \ U0 . ." TERMINATED "
  ['] AtStop U0 ^xt !
  NEXT-T
;
: SUSPEND ( tid -- )
  DUP ^xt @ ['] AtStop = IF DROP EXIT THEN
  ['] AtSuspend OVER ^xt !
  T-SELF = IF NEXT-T THEN
;
: RESUME ( tid -- ) \ WAKE UP
  DUP ^xt @ ['] AtStop = IF DROP EXIT THEN
  ['] AtRun SWAP ^xt !
;

USER T-IOERR  \ значение завершения потока.

DEFINITIONS

: run_as_task ( xt -- )
\ выполняется уже в контексте соответствующего потока
  >R ( чтобы стек был верный )
  USER-INIT R> CATCH  T-IOERR !
  USER-EXIT TERMINATE
;

EXPORT

: TASK ( xt -- task )
  :NONAME ( xt xt2 )
  SWAP
  POSTPONE LITERAL
  POSTPONE run_as_task
  POSTPONE ;
;
: TASK: ( xt "name" -- )
  TASK CONSTANT
;

: WaitTicks ( ticks -- )
  0 TicksCount D+
  BEGIN 2DUP TicksCount D> WHILE NEXT-T REPEAT 2DROP
;
: PAUSE ( ms -- )  \ approximates  = ~ 1/50 с ~ 20 мс
  18 1000 */  WaitTicks
;
: KEY ( -- c )
  BEGIN KEY? IF KEY EXIT THEN NEXT-T AGAIN
;
: EKEY ( -- u )
  BEGIN EKEY? IF EKEY EXIT THEN NEXT-T AGAIN
;

;MODULE

\ ..: USER-INIT T-SELF . ."  INIT, depth= " DEPTH . DUP . ." S: " .S ." |" DEPTH . CR ;..
\ ..: USER-EXIT T-SELF . ."  EXIT, depth= " DEPTH . DUP . ." S: " .S ." |" DEPTH . CR ;..

\ INIT-MTASK
( AT-PROCESS-STARTING прилеплено сверху
 и запускается уже после OPTIONS
 Поэтому INIT-MTASK будет выполнено
 даже если mtask загруженно при выполнении OPTIONS )


 (
0 VALUE d1
: t1 ." t1!!! " . CR ;
' t1 TASK: tt1
: test 12 tt1 START TO d1 d1 . CR ;
\ 12 tt1 START VALUE d2 d2 . CR
\EOF
\ )

mtask.txt

Простейшая многопоточность.
Прикручена сверху, не реентерабельна для процессов VFM
( интерпретация, компиляция, и т.п. остались глобальные )

-501 Очередь потока полна.
-502 Очередь потока пуста.
-550 USER-ALLOT: Не хватает user-области.


AT-PROCESS-STARTING выполняется после OPTIONS :(
из-за прилепления сверху.

mtask_a.f

\ 28.Dec.2001 Fri 11:39

: S0_OLD S0 ; 

USER S0
( а вот обращаться к S0 нельзя,
  пока не будет выполнен INIT-MTASK )

..: USER-INIT
  ( на стеке значение, переданное задаче )
  SP@ CELL+ S0 !
;..

: DEPTH ( -- +n ) \ 93
\ +n - число одинарных ячеек, находящихся на стеке данных перед
\ тем как туда было помещено +n.
  SP@ S0 @ - NEGATE 2/
;

: .S ( -- ) \ 93 TOOLS
\ Скопировать и показать значения, находящиеся на стеке данных. Формат зависит 
\ от реализации.
\ .S может быть реализовано с использованием слов форматного преобразования 
\ чисел. Соответственно, он может испортить перемещаемую область, 
\ идентифицируемую #>.
  DEPTH 0 ?DO DEPTH I - 1- PICK . LOOP
;