1 /* Copyright (C) 1997, 1998, 2000, 2001 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
51 #include "libguile/_scm.h"
52 #include "libguile/async.h"
54 #include "libguile/iselect.h"
58 #include "libguile/coop-threads.h"
62 /* COOP queue macros */
63 #define QEMPTYP(q) (q.t.next == &q.t)
64 #define QFIRST(q) (q.t.next)
66 /* These macros count the number of bits in a word. */
67 #define SCM_BITS_PER_LONG (8 * sizeof (unsigned long))
68 /* Use LONG_MAX instead of ULONG_MAX here since not all systems define
70 #if LONG_MAX >> 16 == 0
71 #define SCM_NLONGBITS(p) (bc[((unsigned char *)(p))[0]]\
72 + bc[((unsigned char *)(p))[1]])
73 #elif LONG_MAX >> 32 == 0 || LONG_MAX == 2147483647L /* bug in Sun CC 4.2 */
74 #define SCM_NLONGBITS(p) (bc[((unsigned char *)(p))[0]]\
75 + bc[((unsigned char *)(p))[1]]\
76 + bc[((unsigned char *)(p))[2]]\
77 + bc[((unsigned char *)(p))[3]])
78 #elif LONG_MAX >> 64 == 0
79 #define SCM_NLONGBITS(p) (bc[((unsigned char *)(p))[0]]\
80 + bc[((unsigned char *)(p))[1]]\
81 + bc[((unsigned char *)(p))[2]]\
82 + bc[((unsigned char *)(p))[3]]\
83 + bc[((unsigned char *)(p))[4]]\
84 + bc[((unsigned char *)(p))[5]]\
85 + bc[((unsigned char *)(p))[6]]\
86 + bc[((unsigned char *)(p))[7]])
88 #error Could not determine suitable definition for SCM_NLONGBITS
91 #define FD_ZERO_N(pos, n) memset ((void *) (pos), 0, (n))
93 typedef unsigned long *ulongptr
;
95 static char bc
[256]; /* Bit counting array. bc[x] is the number of
100 /* This flag indicates that several threads are waiting on the same
101 file descriptor. When this is the case, the common fd sets are
102 updated in a more inefficient way. */
105 /* These are the common fd sets. When new select calls are made,
106 those sets are merged into these. */
108 SELECT_TYPE greadfds
;
109 SELECT_TYPE gwritefds
;
110 SELECT_TYPE gexceptfds
;
112 /* These are the result sets. They are used when we call OS select.
113 We couldn't use the common fd sets above, since that would destroy
115 SELECT_TYPE rreadfds
;
116 SELECT_TYPE rwritefds
;
117 SELECT_TYPE rexceptfds
;
119 /* Constant timeval struct representing a zero timeout which we use
121 static struct timeval timeout0
;
123 /* As select, but doesn't destroy the file descriptor sets passed as
124 arguments. The results are stored into the result sets. */
126 safe_select (int nfds
,
127 SELECT_TYPE
*readfds
,
128 SELECT_TYPE
*writefds
,
129 SELECT_TYPE
*exceptfds
,
130 struct timeval
*timeout
)
132 int n
= (nfds
+ 7) / 8;
133 /* Copy file descriptor sets to result area */
138 memcpy (&rreadfds
, readfds
, n
);
139 FD_ZERO_N ((char *) &rreadfds
+ n
, SELECT_SET_SIZE
/ 8 - n
);
141 if (writefds
== NULL
)
142 FD_ZERO (&rwritefds
);
145 memcpy (&rwritefds
, writefds
, n
);
146 FD_ZERO_N ((char *) &rwritefds
+ n
, SELECT_SET_SIZE
/ 8 - n
);
148 if (exceptfds
== NULL
)
149 FD_ZERO (&rexceptfds
);
152 memcpy (&rexceptfds
, exceptfds
, n
);
153 FD_ZERO_N ((char *) &rexceptfds
+ n
, SELECT_SET_SIZE
/ 8 - n
);
155 return select (nfds
, &rreadfds
, &rwritefds
, &rexceptfds
, timeout
);
158 /* Merge new file descriptor sets into the common sets. */
160 add_fd_sets (coop_t
*t
)
162 int n
= (t
->nfds
+ SCM_BITS_PER_LONG
- 1) / SCM_BITS_PER_LONG
;
165 /* Detect if the fd sets of the thread have any bits in common with
166 the rest of the waiting threads. If that is so, set the
167 collision flag. This causes a more time consuming handling of
168 the common fd sets---they need to recalculated every time a
171 for (i
= 0; i
< n
; ++i
)
172 if ((t
->readfds
!= NULL
173 && (((ulongptr
) t
->readfds
)[i
] & ((ulongptr
) &greadfds
)[i
]) != 0)
174 || (t
->writefds
!= NULL
175 && ((((ulongptr
) t
->writefds
)[i
] & ((ulongptr
) &gwritefds
)[i
])
177 || (t
->exceptfds
!= NULL
178 && ((((ulongptr
) t
->exceptfds
)[i
] & ((ulongptr
) &gexceptfds
)[i
])
185 /* We recalculate nfds below. The cost for this can be paid back
186 with a great bonus since many programs are lazy with the nfds
187 arg. Many even pass 1024 when using one of the lowest fd:s!
189 We approach from above, checking for non-zero bits. As soon as
190 we have determined the value of nfds, we jump down to code below
191 which concludes the updating of the common sets. */
197 if (t
->readfds
!= NULL
&& ((ulongptr
) t
->readfds
)[i
] != 0)
199 ((ulongptr
) &greadfds
)[i
] |= ((ulongptr
) t
->readfds
)[i
];
200 n
= (i
+ 1) * SCM_BITS_PER_LONG
;
206 if (t
->writefds
!= NULL
&& ((ulongptr
) t
->writefds
)[i
] != 0)
208 ((ulongptr
) &gwritefds
)[i
] |= ((ulongptr
) t
->writefds
)[i
];
209 n
= (i
+ 1) * SCM_BITS_PER_LONG
;
215 if (t
->exceptfds
!= NULL
&& ((ulongptr
) t
->exceptfds
)[i
] != 0)
217 ((ulongptr
) &gexceptfds
)[i
] |= ((ulongptr
) t
->exceptfds
)[i
];
218 n
= (i
+ 1) * SCM_BITS_PER_LONG
;
227 /* nfds is now determined. Just finish updating the common sets. */
231 if (t
->readfds
!= NULL
&& ((ulongptr
) t
->readfds
)[i
] != 0)
232 ((ulongptr
) &greadfds
)[i
] |= ((ulongptr
) t
->readfds
)[i
];
234 if (t
->writefds
!= NULL
&& ((ulongptr
) t
->writefds
)[i
] != 0)
235 ((ulongptr
) &gwritefds
)[i
] |= ((ulongptr
) t
->writefds
)[i
];
237 if (t
->exceptfds
!= NULL
&& ((ulongptr
) t
->exceptfds
)[i
] != 0)
238 ((ulongptr
) &gexceptfds
)[i
] |= ((ulongptr
) t
->exceptfds
)[i
];
244 /* Update the fd sets pointed to by the thread so that they reflect
245 the status of the file descriptors which the thread was interested
246 in. Also clear those bits in the common sets. This function is
247 only called when there are no bit collisions. */
249 finalize_fd_sets (coop_t
*t
)
251 int i
= (t
->nfds
+ SCM_BITS_PER_LONG
- 1) / SCM_BITS_PER_LONG
;
253 register unsigned long s
;
255 if (t
->nfds
== gnfds
)
257 /* This thread is the one responsible for the current high value
258 of gnfds. First do our other jobs while at the same time
259 trying to decrease gnfds. */
263 if (t
->readfds
!= NULL
&& (s
= ((ulongptr
) t
->readfds
)[i
]) != 0)
265 ((ulongptr
) t
->readfds
)[i
] &= ((ulongptr
) &rreadfds
)[i
];
266 ((ulongptr
) &greadfds
)[i
] &= ~s
;
267 n_ones
+= SCM_NLONGBITS (&((ulongptr
) t
->readfds
)[i
]);
269 if (((ulongptr
) &greadfds
)[i
] != 0)
271 gnfds
= (i
+ 1) * SCM_BITS_PER_LONG
;
274 if (t
->writefds
!= NULL
&& (s
= ((ulongptr
) t
->writefds
)[i
]) != 0)
276 ((ulongptr
) t
->writefds
)[i
] &= ((ulongptr
) &rwritefds
)[i
];
277 ((ulongptr
) &gwritefds
)[i
] &= ~s
;
278 n_ones
+= SCM_NLONGBITS (&((ulongptr
) t
->writefds
)[i
]);
280 if (((ulongptr
) &gwritefds
)[i
] != 0)
282 gnfds
= (i
+ 1) * SCM_BITS_PER_LONG
;
285 if (t
->exceptfds
!= NULL
&& (s
= ((ulongptr
) t
->exceptfds
)[i
]) != 0)
287 ((ulongptr
) t
->exceptfds
)[i
] &= ((ulongptr
) &rexceptfds
)[i
];
288 ((ulongptr
) &gexceptfds
)[i
] &= ~s
;
289 n_ones
+= SCM_NLONGBITS (&((ulongptr
) t
->exceptfds
)[i
]);
291 if (((ulongptr
) &gexceptfds
)[i
] != 0)
293 gnfds
= (i
+ 1) * SCM_BITS_PER_LONG
;
302 /* Either this thread wasn't responsible for gnfds or gnfds has been
307 if (t
->readfds
!= NULL
&& (s
= ((ulongptr
) t
->readfds
)[i
]) != 0)
309 ((ulongptr
) t
->readfds
)[i
] &= ((ulongptr
) &rreadfds
)[i
];
310 ((ulongptr
) &greadfds
)[i
] &= ~s
;
311 n_ones
+= SCM_NLONGBITS (&((ulongptr
) t
->readfds
)[i
]);
314 if (t
->writefds
!= NULL
&& (s
= ((ulongptr
) t
->writefds
)[i
]) != 0)
316 ((ulongptr
) t
->writefds
)[i
] &= ((ulongptr
) &rwritefds
)[i
];
317 ((ulongptr
) &gwritefds
)[i
] &= ~s
;
318 n_ones
+= SCM_NLONGBITS (&((ulongptr
) t
->writefds
)[i
]);
321 if (t
->exceptfds
!= NULL
&& (s
= ((ulongptr
) t
->exceptfds
)[i
]) != 0)
323 ((ulongptr
) t
->exceptfds
)[i
] &= ((ulongptr
) &rexceptfds
)[i
];
324 ((ulongptr
) &gexceptfds
)[i
] &= ~s
;
325 n_ones
+= SCM_NLONGBITS (&((ulongptr
) t
->exceptfds
)[i
]);
333 /* Just like finalize_fd_sets except that we don't have to update the
334 global fd sets. Those will be recalulated elsewhere. */
336 finalize_fd_sets_lazily (coop_t
*t
)
338 int i
= (t
->nfds
+ SCM_BITS_PER_LONG
- 1) / SCM_BITS_PER_LONG
;
343 if (t
->readfds
!= NULL
&& ((ulongptr
) t
->readfds
)[i
] != 0)
345 ((ulongptr
) t
->readfds
)[i
] &= ((ulongptr
) &rreadfds
)[i
];
346 n_ones
+= SCM_NLONGBITS (&((ulongptr
) t
->readfds
)[i
]);
348 if (t
->writefds
!= NULL
&& ((ulongptr
) t
->writefds
)[i
] != 0)
350 ((ulongptr
) t
->writefds
)[i
] &= ((ulongptr
) &rwritefds
)[i
];
351 n_ones
+= SCM_NLONGBITS (&((ulongptr
) t
->writefds
)[i
]);
353 if (t
->exceptfds
!= NULL
&& ((ulongptr
) t
->exceptfds
)[i
] != 0)
355 ((ulongptr
) t
->exceptfds
)[i
] &= ((ulongptr
) &rexceptfds
)[i
];
356 n_ones
+= SCM_NLONGBITS (&((ulongptr
) t
->exceptfds
)[i
]);
362 /* Return first fd with a non-zero bit in any of the result sets. */
364 first_interesting_fd (void)
370 if (((ulongptr
) &rreadfds
)[i
] != 0)
375 if (((ulongptr
) &rwritefds
)[i
] != 0)
380 if (((ulongptr
) &rexceptfds
)[i
] != 0)
387 i
*= SCM_BITS_PER_LONG
;
394 fprintf (stderr
, "first_interesting_fd: internal error\n");
398 /* Revive all threads with an error status. */
400 scm_error_revive_threads (void)
404 while ((t
= coop_qget (&coop_global_sleepq
)) != NULL
)
408 if (t
!= coop_global_curr
)
409 coop_qput (&coop_global_runq
, t
);
414 FD_ZERO (&gwritefds
);
415 FD_ZERO (&gexceptfds
);
418 /* Given the result of a call to safe_select and the current time,
419 try to wake up some threads and return the first one. Return NULL
420 if we couldn't find any. */
422 find_thread (int n
, struct timeval
*now
, int sleepingp
)
428 /* An error or a signal has occured. Wake all threads. Since we
429 don't care to calculate if there is a sinner we report the
430 error to all of them. */
432 scm_error_revive_threads ();
434 return coop_global_curr
;
438 while (!QEMPTYP (coop_global_sleepq
)
439 && (t
= QFIRST (coop_global_sleepq
))->timeoutp
440 && (t
->wakeup_time
.tv_sec
< now
->tv_sec
441 || (t
->wakeup_time
.tv_sec
== now
->tv_sec
442 && t
->wakeup_time
.tv_usec
<= now
->tv_usec
)))
444 coop_qget (&coop_global_sleepq
);
446 finalize_fd_sets_lazily (t
);
448 finalize_fd_sets (t
);
449 coop_qput (&coop_global_runq
, t
);
453 while ((t
= coop_qget (&coop_global_sleepq
)) != NULL
)
454 coop_qput (&coop_tmp_queue
, t
);
455 goto rebuild_global_fd_sets
;
460 /* Find the first interesting file descriptor */
461 fd
= first_interesting_fd ();
462 /* Check the sleeping queue for this file descriptor.
463 Other file descriptors will be handled next time
464 coop_next_runnable_thread is called. */
465 /* This code is inefficient. We'll improve it later. */
466 while ((t
= coop_qget (&coop_global_sleepq
)) != NULL
)
468 if ((t
->readfds
&& FD_ISSET (fd
, t
->readfds
))
469 || (t
->writefds
&& FD_ISSET (fd
, t
->writefds
))
470 || (t
->exceptfds
&& FD_ISSET (fd
, t
->exceptfds
))
472 && (t
->wakeup_time
.tv_sec
< now
->tv_sec
473 || (t
->wakeup_time
.tv_sec
== now
->tv_sec
474 && t
->wakeup_time
.tv_usec
<= now
->tv_usec
))))
477 finalize_fd_sets_lazily (t
);
479 finalize_fd_sets (t
);
480 coop_qput (&coop_global_runq
, t
);
483 coop_qput(&coop_tmp_queue
, t
);
487 rebuild_global_fd_sets
:
491 FD_ZERO (&gwritefds
);
492 FD_ZERO (&gexceptfds
);
493 while ((t
= coop_qget (&coop_tmp_queue
)) != NULL
)
496 coop_qput (&coop_global_sleepq
, t
);
501 while ((t
= coop_qget (&coop_tmp_queue
)) != NULL
)
502 coop_qput (&coop_global_sleepq
, t
);
506 return coop_qget (&coop_global_runq
);
509 /* Return next runnable thread on the run queue.
510 * First update the queue with possible I/O or timeouts.
511 * If no thread is found, return NULL.
514 coop_next_runnable_thread ()
520 /* Just return next thread on the runq if the sleepq is empty. */
521 if (QEMPTYP (coop_global_sleepq
))
523 if (QEMPTYP (coop_global_runq
))
524 return coop_global_curr
;
526 return coop_qget (&coop_global_runq
);
530 n
= safe_select (gnfds
, &greadfds
, &gwritefds
, &gexceptfds
, &timeout0
);
533 if (QFIRST (coop_global_sleepq
)->timeoutp
)
535 gettimeofday (&now
, NULL
);
536 t
= find_thread (n
, &now
, 0);
539 t
= find_thread (n
, 0, 0);
540 return t
== NULL
? coop_global_curr
: t
;
544 coop_wait_for_runnable_thread_now (struct timeval
*now
)
550 n
= safe_select (gnfds
, &greadfds
, &gwritefds
, &gexceptfds
, &timeout0
);
553 /* Is there any other runnable thread? */
554 t
= find_thread (n
, now
, 1);
557 /* No. Let the process go to sleep. */
558 if ((t
= QFIRST (coop_global_sleepq
))->timeoutp
)
560 now
->tv_sec
= t
->wakeup_time
.tv_sec
- now
->tv_sec
;
561 if (now
->tv_usec
> t
->wakeup_time
.tv_usec
)
564 now
->tv_usec
= 1000000 + t
->wakeup_time
.tv_usec
- now
->tv_usec
;
567 now
->tv_usec
= t
->wakeup_time
.tv_usec
- now
->tv_usec
;
568 n
= safe_select (gnfds
, &greadfds
, &gwritefds
, &gexceptfds
, now
);
571 n
= safe_select (gnfds
, &greadfds
, &gwritefds
, &gexceptfds
, NULL
);
572 gettimeofday (now
, NULL
);
573 t
= find_thread (n
, now
, 1);
580 coop_wait_for_runnable_thread ()
584 if (QEMPTYP (coop_global_sleepq
))
586 if (QEMPTYP (coop_global_runq
))
587 return coop_global_curr
;
589 return coop_qget (&coop_global_runq
);
592 if (QFIRST (coop_global_sleepq
)->timeoutp
)
593 gettimeofday (&now
, NULL
);
595 return coop_wait_for_runnable_thread_now (&now
);
598 /* Initialize bit counting array */
599 static void init_bc (int bit
, int i
, int n
)
605 init_bc (bit
>> 1, i
, n
);
606 init_bc (bit
>> 1, i
| bit
, n
+ 1);
613 #if 0 /* This is just symbolic */
617 FD_ZERO (&gwritefds
);
618 FD_ZERO (&gexceptfds
);
620 timeout0
.tv_usec
= 0;
622 init_bc (0x80, 0, 0);
623 #ifndef SCM_MAGIC_SNARFER
624 #include "libguile/iselect.x"
628 #endif /* GUILE_ISELECT */
631 scm_internal_select (int nfds
,
632 SELECT_TYPE
*readfds
,
633 SELECT_TYPE
*writefds
,
634 SELECT_TYPE
*exceptfds
,
635 struct timeval
*timeout
)
637 #ifndef GUILE_ISELECT
638 int res
= select (nfds
, readfds
, writefds
, exceptfds
, timeout
);
641 #else /* GUILE_ISELECT */
643 coop_t
*t
, *curr
= coop_global_curr
;
645 /* If the timeout is 0, we're polling and can handle it quickly. */
647 && timeout
->tv_sec
== 0
648 && timeout
->tv_usec
== 0)
649 return select (nfds
, readfds
, writefds
, exceptfds
, timeout
);
653 /* Add our file descriptor flags to the common set. */
655 curr
->readfds
= readfds
;
656 curr
->writefds
= writefds
;
657 curr
->exceptfds
= exceptfds
;
660 /* Place ourselves on the sleep queue and get a new thread to run. */
664 coop_qput (&coop_global_sleepq
, curr
);
665 t
= coop_wait_for_runnable_thread ();
669 gettimeofday (&now
, NULL
);
671 curr
->wakeup_time
.tv_sec
= now
.tv_sec
+ timeout
->tv_sec
;
672 curr
->wakeup_time
.tv_usec
= now
.tv_usec
+ timeout
->tv_usec
;
673 if (curr
->wakeup_time
.tv_usec
>= 1000000)
675 ++curr
->wakeup_time
.tv_sec
;
676 curr
->wakeup_time
.tv_usec
-= 1000000;
678 /* Insert the current thread at the right place in the sleep queue */
679 coop_timeout_qinsert (&coop_global_sleepq
, curr
);
680 t
= coop_wait_for_runnable_thread_now (&now
);
683 /* If the new thread is the same as the sleeping thread, do nothing */
684 if (t
!= coop_global_curr
)
686 /* Do a context switch. */
687 coop_global_curr
= t
;
688 QT_BLOCK (coop_sleephelp
, curr
, NULL
, t
->sp
);
691 if (coop_global_curr
->retval
== -1)
692 errno
= coop_global_curr
->_errno
;
695 return coop_global_curr
->retval
;
696 #endif /* GUILE_ISELECT */