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