Powered by ViewCVS 1.0-dev
| 1 : | pazsan | 1.1 | \ posix threads |
| 2 : | |||
| 3 : | \ Copyright (C) 2012 Free Software Foundation, Inc. | ||
| 4 : | |||
| 5 : | \ This file is part of Gforth. | ||
| 6 : | |||
| 7 : | \ Gforth is free software; you can redistribute it and/or | ||
| 8 : | \ modify it under the terms of the GNU General Public License | ||
| 9 : | \ as published by the Free Software Foundation, either version 3 | ||
| 10 : | \ of the License, or (at your option) any later version. | ||
| 11 : | |||
| 12 : | \ This program is distributed in the hope that it will be useful, | ||
| 13 : | \ but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 14 : | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 15 : | \ GNU General Public License for more details. | ||
| 16 : | |||
| 17 : | \ You should have received a copy of the GNU General Public License | ||
| 18 : | \ along with this program. If not, see http://www.gnu.org/licenses/. | ||
| 19 : | |||
| 20 : | c-library pthread | ||
| 21 : | \c #include <pthread.h> | ||
| 22 : | \c #include <limits.h> | ||
| 23 : | \c #include <sys/mman.h> | ||
| 24 : | \c #include <unistd.h> | ||
| 25 : | pazsan | 1.12 | \c #include <setjmp.h> |
| 26 : | \c #include <stdio.h> | ||
| 27 : | pazsan | 1.23 | \c #include <signal.h> |
| 28 : | pazsan | 1.2 | \c #define wholepage(n) (((n)+pagesize-1)&~(pagesize-1)) |
| 29 : | pazsan | 1.6 | \c |
| 30 : | pazsan | 1.33 | \c void gforth_cleanup_thread(void * t) |
| 31 : | pazsan | 1.2 | \c { |
| 32 : | pazsan | 1.1 | \c #if HAVE_GETPAGESIZE |
| 33 : | pazsan | 1.33 | \c Cell pagesize=getpagesize(); /* Linux/GNU libc offers this */ |
| 34 : | pazsan | 1.1 | \c #elif HAVE_SYSCONF && defined(_SC_PAGESIZE) |
| 35 : | pazsan | 1.33 | \c Cell pagesize=sysconf(_SC_PAGESIZE); /* POSIX.4 */ |
| 36 : | pazsan | 1.1 | \c #elif PAGESIZE |
| 37 : | pazsan | 1.33 | \c Cell pagesize=PAGESIZE; /* in limits.h according to Gallmeister's POSIX.4 book */ |
| 38 : | pazsan | 1.23 | \c #endif |
| 39 : | pazsan | 1.12 | \c Cell size = wholepage((Cell)(((user_area*)t)->lp0)+pagesize-(Cell)t); |
| 40 : | pazsan | 1.23 | \c #ifdef SIGSTKSZ |
| 41 : | \c size += 2*SIGSTKSZ; | ||
| 42 : | \c #endif | ||
| 43 : | pazsan | 1.12 | \c munmap(t, size); |
| 44 : | pazsan | 1.10 | \c } |
| 45 : | \c | ||
| 46 : | pazsan | 1.18 | \c #ifndef HAS_BACKLINK |
| 47 : | \c static void *(*saved_gforth_pointers)(Cell); | ||
| 48 : | pazsan | 1.17 | \c #endif |
| 49 : | \c | ||
| 50 : | pazsan | 1.8 | \c void *gforth_thread(user_area * t) |
| 51 : | pazsan | 1.6 | \c { |
| 52 : | pazsan | 1.12 | \c void *x; |
| 53 : | \c int throw_code; | ||
| 54 : | pazsan | 1.21 | \c jmp_buf throw_jmp_buf; |
| 55 : | pazsan | 1.18 | \c #ifndef HAS_BACKLINK |
| 56 : | \c void *(*gforth_pointers)(Cell) = saved_gforth_pointers; | ||
| 57 : | \c #endif | ||
| 58 : | pazsan | 1.22 | \c Cell signal_data_stack[24]; |
| 59 : | \c Cell signal_return_stack[16]; | ||
| 60 : | \c Float signal_fp_stack[1]; | ||
| 61 : | \c void *ip0=(void*)(t->save_task); | ||
| 62 : | \c Cell *sp0=(Cell*)(t->sp0)-1; | ||
| 63 : | \c Cell *rp0=(Cell*)(t->rp0); | ||
| 64 : | \c Float *fp0=(Float*)(t->fp0); | ||
| 65 : | \c void *lp0=(void*)(t->lp0); | ||
| 66 : | \c | ||
| 67 : | pazsan | 1.10 | \c pthread_cleanup_push(&gforth_cleanup_thread, (void*)t); |
| 68 : | pazsan | 1.15 | \c |
| 69 : | pazsan | 1.21 | \c throw_jmp_handler = &throw_jmp_buf; |
| 70 : | pazsan | 1.22 | \c ((Cell*)(t->sp0))[-1]=(Cell)t; |
| 71 : | pazsan | 1.21 | \c |
| 72 : | pazsan | 1.22 | \c while((throw_code=setjmp(*throw_jmp_handler))) { |
| 73 : | pazsan | 1.12 | \c signal_data_stack[15]=throw_code; |
| 74 : | pazsan | 1.22 | \c ip0=(void*)(t->throw_entry); |
| 75 : | \c sp0=signal_data_stack+15; | ||
| 76 : | \c rp0=signal_return_stack+16; | ||
| 77 : | \c fp0=signal_fp_stack; | ||
| 78 : | pazsan | 1.12 | \c } |
| 79 : | pazsan | 1.22 | \c x=gforth_engine(ip0, sp0, rp0, fp0, lp0); |
| 80 : | pazsan | 1.10 | \c pthread_cleanup_pop(1); |
| 81 : | pazsan | 1.23 | \c pthread_exit(x); |
| 82 : | pazsan | 1.1 | \c } |
| 83 : | pazsan | 1.17 | \c #ifdef HAS_BACKLINK |
| 84 : | pazsan | 1.1 | \c void *gforth_thread_p() |
| 85 : | \c { | ||
| 86 : | \c return (void*)&gforth_thread; | ||
| 87 : | \c } | ||
| 88 : | pazsan | 1.17 | \c #else |
| 89 : | \c #define gforth_thread_p() gforth_thread_ptr(gforth_pointers) | ||
| 90 : | \c void *gforth_thread_ptr(GFORTH_ARGS) | ||
| 91 : | \c { | ||
| 92 : | pazsan | 1.18 | \c saved_gforth_pointers=gforth_pointers; |
| 93 : | pazsan | 1.17 | \c return (void*)&gforth_thread; |
| 94 : | \c } | ||
| 95 : | \c #endif | ||
| 96 : | pazsan | 1.1 | \c void *pthread_plus(void * thread) |
| 97 : | \c { | ||
| 98 : | \c return thread+sizeof(pthread_t); | ||
| 99 : | \c } | ||
| 100 : | \c Cell pthreads(Cell thread) | ||
| 101 : | \c { | ||
| 102 : | \c return thread*(int)sizeof(pthread_t); | ||
| 103 : | \c } | ||
| 104 : | pazsan | 1.6 | \c void *pthread_mutex_plus(void * thread) |
| 105 : | \c { | ||
| 106 : | \c return thread+sizeof(pthread_mutex_t); | ||
| 107 : | \c } | ||
| 108 : | \c Cell pthread_mutexes(Cell thread) | ||
| 109 : | \c { | ||
| 110 : | \c return thread*(int)sizeof(pthread_mutex_t); | ||
| 111 : | \c } | ||
| 112 : | pazsan | 1.32 | \c void *pthread_cond_plus(void * thread) |
| 113 : | \c { | ||
| 114 : | \c return thread+sizeof(pthread_cond_t); | ||
| 115 : | \c } | ||
| 116 : | \c Cell pthread_conds(Cell thread) | ||
| 117 : | \c { | ||
| 118 : | \c return thread*(int)sizeof(pthread_cond_t); | ||
| 119 : | \c } | ||
| 120 : | pazsan | 1.23 | \c pthread_attr_t * pthread_detach_attr(void) |
| 121 : | \c { | ||
| 122 : | \c static pthread_attr_t attr; | ||
| 123 : | \c pthread_attr_init(&attr); | ||
| 124 : | \c pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); | ||
| 125 : | \c return &attr; | ||
| 126 : | \c } | ||
| 127 : | pazsan | 1.24 | \c void create_pipe(FILE ** addr) |
| 128 : | \c { | ||
| 129 : | \c int epipe[2]; | ||
| 130 : | \c pipe(epipe); | ||
| 131 : | \c addr[0]=fdopen(epipe[0], "r"); | ||
| 132 : | \c addr[1]=fdopen(epipe[1], "a"); | ||
| 133 : | \c setvbuf(addr[1], NULL, _IONBF, 0); | ||
| 134 : | \c } | ||
| 135 : | pazsan | 1.25 | \c #include <sys/ioctl.h> |
| 136 : | \c #include <errno.h> | ||
| 137 : | \c int check_read(FILE * fid) | ||
| 138 : | \c { | ||
| 139 : | \c int pipe = fileno(fid); | ||
| 140 : | \c int chars_avail; | ||
| 141 : | \c int result = ioctl(pipe, FIONREAD, &chars_avail); | ||
| 142 : | \c return (result==-1) ? -errno : chars_avail; | ||
| 143 : | \c } | ||
| 144 : | pazsan | 1.27 | \c #include <poll.h> |
| 145 : | \c int wait_read(FILE * fid, Cell timeout) | ||
| 146 : | \c { | ||
| 147 : | \c struct pollfd fds = { fileno(fid), POLLIN, 0 }; | ||
| 148 : | \c #ifdef linux | ||
| 149 : | \c struct timespec tout = { timeout/1000000000, timeout%1000000000 }; | ||
| 150 : | \c ppoll(&fds, 1, &tout, 0); | ||
| 151 : | \c #else | ||
| 152 : | \c poll(&fds, 1, timeout/1000000); | ||
| 153 : | \c #endif | ||
| 154 : | \c return check_read(fid); | ||
| 155 : | \c } | ||
| 156 : | pazsan | 1.1 | c-function pthread+ pthread_plus a -- a ( addr -- addr' ) |
| 157 : | c-function pthreads pthreads n -- n ( n -- n' ) | ||
| 158 : | c-function thread_start gforth_thread_p -- a ( -- addr ) | ||
| 159 : | pazsan | 1.33 | c-function gforth_create_thread gforth_stacks n n n n -- a ( dsize rsize fsize lsize -- task ) |
| 160 : | pazsan | 1.1 | c-function pthread_create pthread_create a a a a -- n ( thread attr start arg ) |
| 161 : | pazsan | 1.6 | c-function pthread_exit pthread_exit a -- void ( retaddr -- ) |
| 162 : | c-function pthread_mutex_init pthread_mutex_init a a -- n ( mutex addr -- r ) | ||
| 163 : | c-function pthread_mutex_lock pthread_mutex_lock a -- n ( mutex -- r ) | ||
| 164 : | c-function pthread_mutex_unlock pthread_mutex_unlock a -- n ( mutex -- r ) | ||
| 165 : | c-function pthread-mutex+ pthread_mutex_plus a -- a ( mutex -- mutex' ) | ||
| 166 : | c-function pthread-mutexes pthread_mutexes n -- n ( n -- n' ) | ||
| 167 : | pazsan | 1.32 | c-function pthread-cond+ pthread_cond_plus a -- a ( cond -- cond' ) |
| 168 : | c-function pthread-conds pthread_conds n -- n ( n -- n' ) | ||
| 169 : | pazsan | 1.20 | c-function pause sched_yield -- void ( -- ) |
| 170 : | pazsan | 1.23 | c-function pthread_detatch_attr pthread_detach_attr -- a ( -- addr ) |
| 171 : | pazsan | 1.32 | c-function pthread_cond_signal pthread_cond_signal a -- n ( cond -- r ) |
| 172 : | c-function pthread_cond_broadcast pthread_cond_broadcast a -- n ( cond -- r ) | ||
| 173 : | c-function pthread_cond_wait pthread_cond_wait a a -- n ( cond mutex -- r ) | ||
| 174 : | c-function pthread_cond_timedwait pthread_cond_timedwait a a a -- n ( cond mutex abstime -- r ) | ||
| 175 : | pazsan | 1.24 | c-function create_pipe create_pipe a -- void ( pipefd[2] -- ) |
| 176 : | pazsan | 1.25 | c-function check_read check_read a -- n ( pipefd -- n ) |
| 177 : | pazsan | 1.27 | c-function wait_read wait_read a n -- n ( pipefd timeout -- n ) |
| 178 : | pazsan | 1.1 | end-c-library |
| 179 : | pazsan | 1.2 | |
| 180 : | pazsan | 1.8 | User pthread-id -1 cells pthread+ uallot drop |
| 181 : | pazsan | 1.24 | User epiper |
| 182 : | User epipew | ||
| 183 : | pazsan | 1.8 | |
| 184 : | pazsan | 1.25 | epiper create_pipe \ create pipe for main task |
| 185 : | |||
| 186 : | pazsan | 1.9 | :noname ' >body @ ; |
| 187 : | :noname ' >body @ postpone literal ; | ||
| 188 : | interpret/compile: user' ( 'user' -- n ) | ||
| 189 : | \G USER' computes the task offset of a user variable | ||
| 190 : | |||
| 191 : | pazsan | 1.8 | : >task ( user task -- user' ) + next-task - ; |
| 192 : | pazsan | 1.2 | |
| 193 : | pazsan | 1.10 | : kill-task ( -- ) |
| 194 : | pazsan | 1.24 | epiper @ close-file drop epipew @ close-file drop 0 (bye) ; |
| 195 : | pazsan | 1.10 | |
| 196 : | pazsan | 1.16 | :noname ( -- ) |
| 197 : | pazsan | 1.12 | [ here throw-entry ! ] |
| 198 : | handler @ ?dup-0=-IF | ||
| 199 : | >stderr cr ." uncaught thread exception: " .error cr | ||
| 200 : | pazsan | 1.16 | kill-task |
| 201 : | pazsan | 1.12 | THEN |
| 202 : | pazsan | 1.16 | (throw1) ; drop |
| 203 : | pazsan | 1.12 | |
| 204 : | pazsan | 1.11 | : NewTask4 ( dsize rsize fsize lsize -- task ) |
| 205 : | gforth_create_thread >r | ||
| 206 : | pazsan | 1.12 | throw-entry r@ udp @ throw-entry next-task - /string move |
| 207 : | pazsan | 1.9 | word-pno-size chars dup allocate throw dup holdbufptr r@ >task ! |
| 208 : | + dup holdptr r@ >task ! holdend r@ >task ! | ||
| 209 : | pazsan | 1.24 | epiper r@ >task create_pipe |
| 210 : | pazsan | 1.10 | ['] kill-task >body rp0 r@ >task @ 1 cells - dup rp0 r@ >task ! ! |
| 211 : | pazsan | 1.12 | handler r@ >task off |
| 212 : | pazsan | 1.2 | r> ; |
| 213 : | |||
| 214 : | pazsan | 1.11 | : NewTask ( stacksize -- task ) dup 2dup NewTask4 ; |
| 215 : | |||
| 216 : | pazsan | 1.15 | : (activate) ( task -- ) |
| 217 : | r> swap >r save-task r@ >task ! | ||
| 218 : | pazsan | 1.23 | pthread-id r@ >task pthread_detatch_attr thread_start r> pthread_create drop ; compile-only |
| 219 : | pazsan | 1.7 | |
| 220 : | pazsan | 1.19 | : activate ( task -- ) |
| 221 : | ]] (activate) up! [[ ; immediate compile-only | ||
| 222 : | pazsan | 1.15 | |
| 223 : | pazsan | 1.14 | : (pass) ( x1 .. xn n task -- ) |
| 224 : | pazsan | 1.15 | r> swap >r save-task r@ >task ! |
| 225 : | pazsan | 1.14 | 1+ dup cells negate sp0 r@ >task @ -rot sp0 r@ >task +! |
| 226 : | sp0 r@ >task @ swap 0 ?DO tuck ! cell+ LOOP drop | ||
| 227 : | pazsan | 1.16 | pthread-id r@ >task 0 thread_start r> pthread_create drop ; compile-only |
| 228 : | pazsan | 1.14 | |
| 229 : | pazsan | 1.19 | : pass ( x1 .. xn n task -- ) |
| 230 : | ]] (pass) up! sp0 ! [[ ; immediate compile-only | ||
| 231 : | pazsan | 1.14 | |
| 232 : | pazsan | 1.9 | : sema ( "name" -- ) \ gforth |
| 233 : | \G create a named semaphore | ||
| 234 : | pazsan | 1.6 | Create here 1 pthread-mutexes allot 0 pthread_mutex_init drop ; |
| 235 : | |||
| 236 : | pazsan | 1.32 | : cond ( "name" -- ) \ gforth |
| 237 : | \G create a named condition | ||
| 238 : | Create here 1 pthread-conds dup allot erase ; | ||
| 239 : | |||
| 240 : | pazsan | 1.6 | : lock ( addr -- ) pthread_mutex_lock drop ; |
| 241 : | : unlock ( addr -- ) pthread_mutex_unlock drop ; | ||
| 242 : | |||
| 243 : | pazsan | 1.19 | : stacksize ( -- n ) forthstart 4 cells + @ |
| 244 : | sp0 @ $FFF and -$1000 or + ; | ||
| 245 : | pazsan | 1.11 | : stacksize4 ( -- dsize rsize fsize lsize ) |
| 246 : | pazsan | 1.19 | forthstart 4 cells + 4 cells bounds DO I @ cell +LOOP |
| 247 : | 2swap swap sp0 @ $FFF and -$1000 or + swap 2swap | ||
| 248 : | swap fp0 @ $FFF and -$1000 or + swap ; | ||
| 249 : | pazsan | 1.7 | |
| 250 : | pazsan | 1.25 | \ event handling |
| 251 : | |||
| 252 : | s" Undefined event" exception Constant !!event!! | ||
| 253 : | s" Event buffer full" exception Constant !!ebuffull!! | ||
| 254 : | |||
| 255 : | Variable event# 1 event# ! | ||
| 256 : | |||
| 257 : | User eventbuf# $100 uallot drop \ 256 bytes buffer for atomic event squences | ||
| 258 : | pazsan | 1.32 | -1 eventbuf# ! |
| 259 : | pazsan | 1.25 | |
| 260 : | : <event eventbuf# off ; | ||
| 261 : | : 'event ( -- addr ) eventbuf# dup @ + cell+ ; | ||
| 262 : | : event+ ( n -- addr ) | ||
| 263 : | dup eventbuf# @ + $100 u>= !!ebuffull!! and throw | ||
| 264 : | 'event swap eventbuf# +! ; | ||
| 265 : | pazsan | 1.32 | : event> ( task -- ) >r eventbuf# cell+ eventbuf# @ -1 eventbuf# ! |
| 266 : | pazsan | 1.25 | epipew r> >task @ write-file throw ; |
| 267 : | |||
| 268 : | : event-crash !!event!! throw ; | ||
| 269 : | |||
| 270 : | Create event-table $100 0 [DO] ' event-crash , [LOOP] | ||
| 271 : | |||
| 272 : | pazsan | 1.32 | : event-does ( task/ -- ) DOES> @ eventbuf# @ 0< dup >r IF <event THEN |
| 273 : | 'event c! 1 eventbuf# +! r> IF event> THEN ; | ||
| 274 : | pazsan | 1.25 | : event: Create event# @ , event-does |
| 275 : | here 0 , >r noname : lastxt dup event# @ cells event-table + ! | ||
| 276 : | r> ! 1 event# +! ; | ||
| 277 : | pazsan | 1.31 | : (stop) ( -- ) epiper @ key-file cells event-table + perform ; |
| 278 : | : event? ( -- flag ) epiper @ check_read 0> ; | ||
| 279 : | : ?events ( -- ) BEGIN event? WHILE (stop) REPEAT ; | ||
| 280 : | : stop ( -- ) (stop) ?events ; | ||
| 281 : | pazsan | 1.27 | : stop-ns ( timeout -- ) epiper @ swap wait_read 0> IF stop THEN ; |
| 282 : | pazsan | 1.26 | : event-loop ( -- ) BEGIN stop AGAIN ; |
| 283 : | pazsan | 1.25 | |
| 284 : | pazsan | 1.29 | event: ->lit 0 sp@ cell epiper @ read-file throw drop ; |
| 285 : | event: ->flit 0e fp@ float epiper @ read-file throw drop ; | ||
| 286 : | event: ->wake ; | ||
| 287 : | event: ->sleep stop ; | ||
| 288 : | |||
| 289 : | : wake ( task -- ) <event ->wake event> ; | ||
| 290 : | : sleep ( task -- ) <event ->sleep event> ; | ||
| 291 : | |||
| 292 : | : elit, ( x -- ) ->lit cell event+ [ cell 8 = ] [IF] x! [ELSE] l! [THEN] ; | ||
| 293 : | pazsan | 1.30 | : e$, ( addr u -- ) swap elit, elit, ; |
| 294 : | pazsan | 1.29 | : eflit, ( x -- ) ->flit fp@ float event+ float move fdrop ; |
| 295 : | pazsan | 1.25 | |
| 296 : | false [IF] \ event test | ||
| 297 : | <event 1234 elit, next-task event> ?event 1234 = [IF] ." event ok" cr [THEN] | ||
| 298 : | [THEN] | ||
| 299 : | |||
| 300 : | pazsan | 1.8 | false [IF] \ test |
| 301 : | pazsan | 1.33 | sema testsem |
| 302 : | pazsan | 1.6 | |
| 303 : | : test-thread1 | ||
| 304 : | pazsan | 1.25 | stacksize4 NewTask4 activate 0 hex |
| 305 : | pazsan | 1.6 | BEGIN |
| 306 : | testsem lock | ||
| 307 : | pazsan | 1.7 | ." Thread-Test1 " dup . cr 1000 ms |
| 308 : | testsem unlock 1+ | ||
| 309 : | pazsan | 1.6 | 100 0 DO pause LOOP |
| 310 : | AGAIN ; | ||
| 311 : | |||
| 312 : | : test-thread2 | ||
| 313 : | pazsan | 1.25 | stacksize4 NewTask4 activate 0 decimal |
| 314 : | pazsan | 1.6 | BEGIN |
| 315 : | testsem lock | ||
| 316 : | pazsan | 1.7 | ." Thread-Test2 " dup . cr 1000 ms |
| 317 : | testsem unlock 1+ | ||
| 318 : | pazsan | 1.6 | 100 0 DO pause LOOP |
| 319 : | AGAIN ; | ||
| 320 : | pazsan | 1.2 | |
| 321 : | pazsan | 1.7 | test-thread1 |
| 322 : | test-thread2 | ||
| 323 : | pazsan | 1.12 | [THEN] |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |