Skip to content

Instantly share code, notes, and snippets.

@ruv

ruv/mtask.f Secret

Last active March 24, 2023 18:34
Show Gist options
  • Save ruv/69b330269234b9b13d1563b2beeb120f to your computer and use it in GitHub Desktop.
Save ruv/69b330269234b9b13d1563b2beeb120f to your computer and use it in GitHub Desktop.
Multihtreading in SP-Forth/2 spf2.5.15
\ 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
\ )
Простейшая многопоточность.
Прикручена сверху, не реентерабельна для процессов VFM
( интерпретация, компиляция, и т.п. остались глобальные )
-501 Очередь потока полна.
-502 Очередь потока пуста.
-550 USER-ALLOT: Не хватает user-области.
AT-PROCESS-STARTING выполняется после OPTIONS :(
из-за прилепления сверху.
\ 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
;
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment