basis/core-foundation/run-loop/run-loop.factor

   1 ! Copyright (C) 2008 Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.syntax kernel math namespaces
   4 sequences destructors combinators threads heaps deques calendar
   5 core-foundation core-foundation.strings
   6 core-foundation.file-descriptors core-foundation.timers
   7 core-foundation.time ;
   8 IN: core-foundation.run-loop
   9
  10 : kCFRunLoopRunFinished 1 ; inline
  11 : kCFRunLoopRunStopped 2 ; inline
  12 : kCFRunLoopRunTimedOut 3 ; inline
  13 : kCFRunLoopRunHandledSource 4 ; inline
  14
  15 TYPEDEF: void* CFRunLoopRef
  16 TYPEDEF: void* CFRunLoopSourceRef
  17
  18 FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
  19 FUNCTION: CFRunLoopRef CFRunLoopGetCurrent ( ) ;
  20
  21 FUNCTION: SInt32 CFRunLoopRunInMode (
  22     CFStringRef mode,
  23     CFTimeInterval seconds,
  24     Boolean returnAfterSourceHandled
  25 ) ;
  26
  27 FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource (
  28     CFAllocatorRef allocator,
  29     CFFileDescriptorRef f,
  30     CFIndex order
  31 ) ;
  32
  33 FUNCTION: void CFRunLoopAddSource (
  34     CFRunLoopRef rl,
  35     CFRunLoopSourceRef source,
  36     CFStringRef mode
  37 ) ;
  38
  39 FUNCTION: void CFRunLoopRemoveSource (
  40     CFRunLoopRef rl,
  41     CFRunLoopSourceRef source,
  42     CFStringRef mode
  43 ) ;
  44
  45 FUNCTION: void CFRunLoopAddTimer (
  46     CFRunLoopRef rl,
  47     CFRunLoopTimerRef timer,
  48     CFStringRef mode
  49 ) ;
  50
  51 FUNCTION: void CFRunLoopRemoveTimer (
  52     CFRunLoopRef rl,
  53     CFRunLoopTimerRef timer,
  54     CFStringRef mode
  55 ) ;
  56
  57 : CFRunLoopDefaultMode ( -- alien )
  58     #! Ugly, but we don't have static NSStrings
  59     \ CFRunLoopDefaultMode get-global dup expired? [
  60         drop
  61         "kCFRunLoopDefaultMode" <CFString>
  62         dup \ CFRunLoopDefaultMode set-global
  63     ] when ;
  64
  65 TUPLE: run-loop fds sources timers ;
  66
  67 : <run-loop> ( -- run-loop )
  68     V{ } clone V{ } clone V{ } clone \ run-loop boa ;
  69
  70 SYMBOL: expiry-check
  71
  72 : run-loop ( -- run-loop )
  73     \ run-loop get-global not expiry-check get expired? or
  74     [
  75         31337 <alien> expiry-check set-global
  76         <run-loop> dup \ run-loop set-global
  77     ] [ \ run-loop get-global ] if ;
  78
  79 : add-source-to-run-loop ( source -- )
  80     [ run-loop sources>> push ]
  81     [
  82         CFRunLoopGetMain
  83         swap CFRunLoopDefaultMode
  84         CFRunLoopAddSource
  85     ] bi ;
  86
  87 : create-fd-source ( CFFileDescriptor -- source )
  88     f swap 0 CFFileDescriptorCreateRunLoopSource ;
  89
  90 : add-fd-to-run-loop ( fd callback -- )
  91     [
  92         <CFFileDescriptor> |CFRelease
  93         [ run-loop fds>> push ]
  94         [ create-fd-source |CFRelease add-source-to-run-loop ]
  95         bi
  96     ] with-destructors ;
  97
  98 : add-timer-to-run-loop ( timer -- )
  99     [ run-loop timers>> push ]
 100     [
 101         CFRunLoopGetMain
 102         swap CFRunLoopDefaultMode
 103         CFRunLoopAddTimer
 104     ] bi ;
 105
 106 <PRIVATE
 107
 108 : ((reset-timer)) ( timer counter timestamp -- )
 109     nip >CFAbsoluteTime CFRunLoopTimerSetNextFireDate ;
 110
 111 : (reset-timer) ( timer counter -- )
 112     yield {
 113         { [ dup 0 = ] [ now ((reset-timer)) ] }
 114         { [ run-queue deque-empty? not ] [ 1- (reset-timer) ] }
 115         { [ sleep-queue heap-empty? ] [ 5 minutes hence ((reset-timer)) ] }
 116         [ sleep-queue heap-peek nip micros>timestamp ((reset-timer)) ]
 117     } cond ;
 118
 119 : reset-timer ( timer -- )
 120     10 (reset-timer) ;
 121
 122 PRIVATE>
 123
 124 : reset-run-loop ( -- )
 125     run-loop
 126     [ timers>> [ reset-timer ] each ]
 127     [ fds>> [ enable-all-callbacks ] each ] bi ;
 128
 129 : timer-callback ( -- callback )
 130     "void" { "CFRunLoopTimerRef" "void*" } "cdecl"
 131     [ 2drop reset-run-loop yield ] alien-callback ;
 132
 133 : init-thread-timer ( -- )
 134     timer-callback <CFTimer> add-timer-to-run-loop ;
 135
 136 : run-one-iteration ( us -- handled? )
 137     reset-run-loop
 138     CFRunLoopDefaultMode
 139     swap [ microseconds ] [ 5 minutes ] if* >CFTimeInterval
 140     t CFRunLoopRunInMode kCFRunLoopRunHandledSource = ;