[gforth] / gforth / unix / pthread.fs  

gforth: gforth/unix/pthread.fs

Diff for /gforth/unix/pthread.fs between version 1.6 and 1.30

version 1.6, Wed Mar 14 23:06:25 2012 UTC version 1.30, Fri May 4 20:50:30 2012 UTC
Line 22 
Line 22 
     \c #include <limits.h>      \c #include <limits.h>
     \c #include <sys/mman.h>      \c #include <sys/mman.h>
     \c #include <unistd.h>      \c #include <unistd.h>
       \c #include <setjmp.h>
       \c #include <stdio.h>
       \c #include <signal.h>
     \c #define wholepage(n) (((n)+pagesize-1)&~(pagesize-1))      \c #define wholepage(n) (((n)+pagesize-1)&~(pagesize-1))
     \c typedef struct {      \c typedef struct {
     \c   Cell data_stack_size;      \c   Cell next_task;
     \c   Cell fp_stack_size;      \c   Cell prev_task;
     \c   Cell return_stack_size;      \c   Cell save_task;
     \c   Cell locals_stack_size;      \c   Cell sp0, rp0, fp0, lp0;
     \c   Cell sp0, fp0, rp0, lp0;      \c   Cell throw_entry;
     \c   Cell boot_entry;      \c } user_area;
     \c   Cell saved_ip, saved_rp;  
     \c } threadId;  
     \c int pagesize = 1;      \c int pagesize = 1;
     \c void page_noaccess(void *a)      \c void page_noaccess(void *a)
     \c {      \c {
Line 65 
Line 66 
     \c   return r;      \c   return r;
     \c }      \c }
     \c      \c
     \c int gforth_create_thread(threadId * t)      \c Cell gforth_create_thread(Cell dsize, Cell rsize, Cell fsize, Cell lsize)
     \c {      \c {
     \c #if HAVE_GETPAGESIZE      \c #if HAVE_GETPAGESIZE
     \c   pagesize=getpagesize(); /* Linux/GNU libc offers this */      \c   pagesize=getpagesize(); /* Linux/GNU libc offers this */
Line 74 
Line 75 
     \c #elif PAGESIZE      \c #elif PAGESIZE
     \c   pagesize=PAGESIZE; /* in limits.h according to Gallmeister's POSIX.4 book */      \c   pagesize=PAGESIZE; /* in limits.h according to Gallmeister's POSIX.4 book */
     \c #endif      \c #endif
     \c   Cell dsize = wholepage(t->data_stack_size);      \c #ifdef SIGSTKSZ
     \c   Cell rsize = wholepage(t->return_stack_size);      \c   stack_t sigstack;
     \c   Cell fsize = wholepage(t->fp_stack_size);      \c   int sas_retval=-1;
     \c   Cell lsize = wholepage(t->locals_stack_size);      \c #endif
     \c   size_t totalsize = dsize+fsize+rsize+lsize+5*pagesize;      \c   size_t totalsize;
     \c   Cell a = (Cell)alloc_mmap(totalsize);      \c   Cell a;
       \c   user_area * up0;
       \c   Cell dsizep = wholepage(dsize);
       \c   Cell rsizep = wholepage(rsize);
       \c   Cell fsizep = wholepage(fsize);
       \c   Cell lsizep = wholepage(lsize);
       \c   totalsize = dsizep+fsizep+rsizep+lsizep+6*pagesize;
       \c #ifdef SIGSTKSZ
       \c   totalsize += 2*SIGSTKSZ;
       \c #endif
       \c   a = (Cell)alloc_mmap(totalsize);
     \c   if (a != (Cell)MAP_FAILED) {      \c   if (a != (Cell)MAP_FAILED) {
     \c     page_noaccess((void*)a); a+=pagesize; a+=dsize; t->sp0=a;      \c     up0=(user_area*)a; a+=pagesize;
     \c     page_noaccess((void*)a); a+=pagesize; a+=fsize; t->fp0=a;      \c     page_noaccess((void*)a); a+=pagesize; up0->sp0=a+dsize; a+=dsizep;
     \c     page_noaccess((void*)a); a+=pagesize; a+=rsize; t->rp0=a;      \c     page_noaccess((void*)a); a+=pagesize; up0->fp0=a+fsize; a+=fsizep;
     \c     page_noaccess((void*)a); a+=pagesize; a+=lsize; t->lp0=a;      \c     page_noaccess((void*)a); a+=pagesize; up0->rp0=a+rsize; a+=rsizep;
     \c     page_noaccess((void*)a);      \c     page_noaccess((void*)a); a+=pagesize; up0->lp0=a+lsize; a+=lsizep;
     \c     return 1;      \c     page_noaccess((void*)a); a+=pagesize;
       \c #ifdef SIGSTKSZ
       \c     sigstack.ss_sp=(void*)a+SIGSTKSZ;
       \c     sigstack.ss_size=SIGSTKSZ;
       \c     sas_retval=sigaltstack(&sigstack,(stack_t *)0);
       \c #endif
       \c     return (Cell)up0;
     \c   }      \c   }
     \c   return 0;      \c   return 0;
     \c }      \c }
     \c      \c
     \c void *gforth_thread(threadId * t)      \c void gforth_cleanup_thread(void * t)
     \c {      \c {
     \c   if(gforth_create_thread(t)) {      \c   Cell size = wholepage((Cell)(((user_area*)t)->lp0)+pagesize-(Cell)t);
     \c     return gforth_engine((void*)(t->boot_entry), (Cell*)(t->sp0), (Cell*)(t->rp0), (Float*)(t->fp0), (void*)(t->lp0), (char*)&(t->saved_ip));      \c #ifdef SIGSTKSZ
       \c   size += 2*SIGSTKSZ;
       \c #endif
       \c   munmap(t, size);
     \c   }      \c   }
     \c   return NULL;      \c
       \c #ifndef HAS_BACKLINK
       \c static void *(*saved_gforth_pointers)(Cell);
       \c #endif
       \c
       \c void *gforth_thread(user_area * t)
       \c {
       \c   void *x;
       \c   int throw_code;
       \c   jmp_buf throw_jmp_buf;
       \c #ifndef HAS_BACKLINK
       \c   void *(*gforth_pointers)(Cell) = saved_gforth_pointers;
       \c #endif
       \c   Cell signal_data_stack[24];
       \c   Cell signal_return_stack[16];
       \c   Float signal_fp_stack[1];
       \c   void *ip0=(void*)(t->save_task);
       \c   Cell *sp0=(Cell*)(t->sp0)-1;
       \c   Cell *rp0=(Cell*)(t->rp0);
       \c   Float *fp0=(Float*)(t->fp0);
       \c   void *lp0=(void*)(t->lp0);
       \c
       \c   pthread_cleanup_push(&gforth_cleanup_thread, (void*)t);
       \c
       \c   throw_jmp_handler = &throw_jmp_buf;
       \c   ((Cell*)(t->sp0))[-1]=(Cell)t;
       \c
       \c   while((throw_code=setjmp(*throw_jmp_handler))) {
       \c     signal_data_stack[15]=throw_code;
       \c     ip0=(void*)(t->throw_entry);
       \c     sp0=signal_data_stack+15;
       \c     rp0=signal_return_stack+16;
       \c     fp0=signal_fp_stack;
       \c   }
       \c   x=gforth_engine(ip0, sp0, rp0, fp0, lp0);
       \c   pthread_cleanup_pop(1);
       \c   pthread_exit(x);
     \c }      \c }
       \c #ifdef HAS_BACKLINK
     \c void *gforth_thread_p()      \c void *gforth_thread_p()
     \c {      \c {
     \c   return (void*)&gforth_thread;      \c   return (void*)&gforth_thread;
     \c }      \c }
       \c #else
       \c #define gforth_thread_p() gforth_thread_ptr(gforth_pointers)
       \c void *gforth_thread_ptr(GFORTH_ARGS)
       \c {
       \c   saved_gforth_pointers=gforth_pointers;
       \c   return (void*)&gforth_thread;
       \c }
       \c #endif
     \c void *pthread_plus(void * thread)      \c void *pthread_plus(void * thread)
     \c {      \c {
     \c   return thread+sizeof(pthread_t);      \c   return thread+sizeof(pthread_t);
Line 118 
Line 183 
     \c {      \c {
     \c   return thread*(int)sizeof(pthread_mutex_t);      \c   return thread*(int)sizeof(pthread_mutex_t);
     \c }      \c }
       \c pthread_attr_t * pthread_detach_attr(void)
       \c {
       \c   static pthread_attr_t attr;
       \c   pthread_attr_init(&attr);
       \c   pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
       \c   return &attr;
       \c }
       \c void create_pipe(FILE ** addr)
       \c {
       \c   int epipe[2];
       \c   pipe(epipe);
       \c   addr[0]=fdopen(epipe[0], "r");
       \c   addr[1]=fdopen(epipe[1], "a");
       \c   setvbuf(addr[1], NULL, _IONBF, 0);
       \c }
       \c #include <sys/ioctl.h>
       \c #include <errno.h>
       \c int check_read(FILE * fid)
       \c {
       \c   int pipe = fileno(fid);
       \c   int chars_avail;
       \c   int result = ioctl(pipe, FIONREAD, &chars_avail);
       \c   return (result==-1) ? -errno : chars_avail;
       \c }
       \c #include <poll.h>
       \c int wait_read(FILE * fid, Cell timeout)
       \c {
       \c   struct pollfd fds = { fileno(fid), POLLIN, 0 };
       \c #ifdef linux
       \c   struct timespec tout = { timeout/1000000000, timeout%1000000000 };
       \c   ppoll(&fds, 1, &tout, 0);
       \c #else
       \c   poll(&fds, 1, timeout/1000000);
       \c #endif
       \c   return check_read(fid);
       \c }
     c-function pthread+ pthread_plus a -- a ( addr -- addr' )      c-function pthread+ pthread_plus a -- a ( addr -- addr' )
     c-function pthreads pthreads n -- n ( n -- n' )      c-function pthreads pthreads n -- n ( n -- n' )
     c-function thread_start gforth_thread_p -- a ( -- addr )      c-function thread_start gforth_thread_p -- a ( -- addr )
       c-function gforth_create_thread gforth_create_thread n n n n -- a ( dsize rsize fsize lsize -- task )
     c-function pthread_create pthread_create a a a a -- n ( thread attr start arg )      c-function pthread_create pthread_create a a a a -- n ( thread attr start arg )
     c-function pthread_exit pthread_exit a -- void ( retaddr -- )      c-function pthread_exit pthread_exit a -- void ( retaddr -- )
     c-function pthread_mutex_init pthread_mutex_init a a -- n ( mutex addr -- r )      c-function pthread_mutex_init pthread_mutex_init a a -- n ( mutex addr -- r )
Line 128 
Line 230 
     c-function pthread_mutex_unlock pthread_mutex_unlock a -- n ( mutex -- r )      c-function pthread_mutex_unlock pthread_mutex_unlock a -- n ( mutex -- r )
     c-function pthread-mutex+ pthread_mutex_plus a -- a ( mutex -- mutex' )      c-function pthread-mutex+ pthread_mutex_plus a -- a ( mutex -- mutex' )
     c-function pthread-mutexes pthread_mutexes n -- n ( n -- n' )      c-function pthread-mutexes pthread_mutexes n -- n ( n -- n' )
     c-function pause pthread_yield -- void ( -- )      c-function pause sched_yield -- void ( -- )
       c-function pthread_detatch_attr pthread_detach_attr -- a ( -- addr )
       c-function create_pipe create_pipe a -- void ( pipefd[2] -- )
       c-function check_read check_read a -- n ( pipefd -- n )
       c-function wait_read wait_read a n -- n ( pipefd timeout -- n )
 end-c-library  end-c-library
   
 begin-structure threadId  User pthread-id  -1 cells pthread+ uallot drop
 field: data_stack_size  User epiper
 field: fp_stack_size  User epipew
 field: return_stack_size  
 field: locals_stack_size  epiper create_pipe \ create pipe for main task
 field: t_sp0  
 field: t_fp0  :noname    ' >body @ ;
 field: t_rp0  :noname    ' >body @ postpone literal ;
 field: t_lp0  interpret/compile: user' ( 'user' -- n )
 field: boot_entry  \G USER' computes the task offset of a user variable
 field: saved_ip  
 field: saved_rp  : >task ( user task -- user' )  + next-task - ;
 1 pthreads +field t_pthread  
 end-structure  : kill-task ( -- )
       epiper @ close-file drop   epipew @ close-file drop  0 (bye) ;
 : new-thread ( xt -- id )  
     threadId allocate throw >r  :noname ( -- )
     forthstart 3 cells + r@ 4 cells move      [ here throw-entry ! ]
     >body r@ boot_entry !      handler @ ?dup-0=-IF
     r@ t_pthread 0 thread_start r@ pthread_create          >stderr cr ." uncaught thread exception: " .error cr
     drop \ fixme          kill-task
       THEN
       (throw1) ; drop
   
   : NewTask4 ( dsize rsize fsize lsize -- task )
       gforth_create_thread >r
       throw-entry r@ udp @ throw-entry next-task - /string move
       word-pno-size chars dup allocate throw dup holdbufptr r@ >task !
       + dup holdptr r@ >task !  holdend r@ >task !
       epiper r@ >task create_pipe
       ['] kill-task >body  rp0 r@ >task @ 1 cells - dup rp0 r@ >task ! !
       handler r@ >task off
     r> ;      r> ;
   
 : semaphore ( "name" -- )  : NewTask ( stacksize -- task )  dup 2dup NewTask4 ;
   
   : (activate) ( task -- )
       r> swap >r  save-task r@ >task !
       pthread-id r@ >task pthread_detatch_attr thread_start r> pthread_create drop ; compile-only
   
   : activate ( task -- )
       ]] (activate) up! [[ ; immediate compile-only
   
   : (pass) ( x1 .. xn n task -- )
       r> swap >r  save-task r@ >task !
       1+ dup cells negate  sp0 r@ >task @ -rot  sp0 r@ >task +!
       sp0 r@ >task @ swap 0 ?DO  tuck ! cell+  LOOP  drop
       pthread-id r@ >task 0 thread_start r> pthread_create drop ; compile-only
   
   : pass ( x1 .. xn n task -- )
       ]] (pass) up! sp0 ! [[ ; immediate compile-only
   
   : sema ( "name" -- ) \ gforth
       \G create a named semaphore
     Create here 1 pthread-mutexes allot 0 pthread_mutex_init drop ;      Create here 1 pthread-mutexes allot 0 pthread_mutex_init drop ;
   
 : lock ( addr -- )  pthread_mutex_lock drop ;  : lock ( addr -- )  pthread_mutex_lock drop ;
 : unlock ( addr -- )  pthread_mutex_unlock drop ;  : unlock ( addr -- )  pthread_mutex_unlock drop ;
   
   : stacksize ( -- n ) forthstart 4 cells + @
       sp0 @ $FFF and -$1000 or + ;
   : stacksize4 ( -- dsize rsize fsize lsize )
       forthstart 4 cells + 4 cells bounds DO  I @  cell +LOOP
       2swap swap sp0 @ $FFF and -$1000 or + swap 2swap
       swap       fp0 @ $FFF and -$1000 or + swap ;
   
   \ event handling
   
   s" Undefined event"   exception Constant !!event!!
   s" Event buffer full" exception Constant !!ebuffull!!
   
   Variable event#  1 event# !
   
   User eventbuf# $100 uallot drop \ 256 bytes buffer for atomic event squences
   
   : <event  eventbuf# off ;
   : 'event ( -- addr )  eventbuf# dup @ + cell+ ;
   : event+ ( n -- addr )
       dup eventbuf# @ + $100 u>= !!ebuffull!! and throw
       'event swap eventbuf# +! ;
   : event> ( task -- )  >r eventbuf# cell+ eventbuf# @
       epipew r> >task @ write-file throw ;
   
   : event-crash  !!event!! throw ;
   
   Create event-table $100 0 [DO] ' event-crash , [LOOP]
   
   : event-does ( -- )  DOES>  @ 'event c! 1 eventbuf# +! ;
   : event:  Create event# @ ,  event-does
       here 0 , >r  noname : lastxt dup event# @ cells event-table + !
       r> ! 1 event# +! ;
   : stop ( -- )  epiper @ key-file cells event-table + perform ;
   : stop-ns ( timeout -- ) epiper @ swap wait_read 0> IF  stop  THEN ;
   : event? ( -- flag )  epiper @ check_read 0> ;
   : ?events ( -- )  BEGIN  event?  WHILE  stop  REPEAT ;
   : event-loop ( -- )  BEGIN  stop  AGAIN ;
   
   event: ->lit  0  sp@ cell  epiper @ read-file throw drop ;
   event: ->flit 0e fp@ float epiper @ read-file throw drop ;
   event: ->wake ;
   event: ->sleep  stop ;
   
   : wake ( task -- )  <event ->wake event> ;
   : sleep ( task -- ) <event ->sleep event> ;
   
   : elit,  ( x -- ) ->lit cell event+ [ cell 8 = ] [IF] x! [ELSE] l! [THEN] ;
   : e$, ( addr u -- )  swap elit, elit, ;
   : eflit, ( x -- ) ->flit fp@ float event+ float move fdrop ;
   
   false [IF] \ event test
       <event 1234 elit, next-task event> ?event 1234 = [IF] ." event ok" cr [THEN]
   [THEN]
   
 false [IF] \ test  false [IF] \ test
     semaphore testsem      semaphore testsem
   
     : test-thread1      : test-thread1
           stacksize4 NewTask4 activate  0 hex
         BEGIN          BEGIN
             testsem lock              testsem lock
             ." Thread-Test1" cr 1000 ms              ." Thread-Test1 " dup . cr 1000 ms
             testsem unlock              testsem unlock  1+
             100 0 DO  pause  LOOP              100 0 DO  pause  LOOP
         AGAIN ;          AGAIN ;
   
     : test-thread2      : test-thread2
           stacksize4 NewTask4 activate  0 decimal
         BEGIN          BEGIN
             testsem lock              testsem lock
             ." Thread-Test2" cr 1000 ms              ." Thread-Test2 " dup . cr 1000 ms
             testsem unlock              testsem unlock  1+
             100 0 DO  pause  LOOP              100 0 DO  pause  LOOP
         AGAIN ;          AGAIN ;
   
     ' test-thread1 new-thread Constant test-id1      test-thread1
     ' test-thread2 new-thread Constant test-id2      test-thread2
 [THEN]  [THEN]

Generate output suitable for use with a patch program
Legend:
Removed from v.1.6  
changed lines
  Added in v.1.30
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help