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 CONSTANT: kCFRunLoopRunFinished 1
  11 CONSTANT: kCFRunLoopRunStopped 2
  12 CONSTANT: kCFRunLoopRunTimedOut 3
  13 CONSTANT: kCFRunLoopRunHandledSource 4
  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 [
  60         "kCFRunLoopDefaultMode" <CFString>
  61     ] initialize-alien ;
  62
  63 TUPLE: run-loop fds sources timers ;
  64
  65 : <run-loop> ( -- run-loop )
  66     V{ } clone V{ } clone V{ } clone \ run-loop boa ;
  67
  68 : run-loop ( -- run-loop )
  69     \ run-loop [ <run-loop> ] initialize-alien ;
  70
  71 : add-source-to-run-loop ( source -- )
  72     [ run-loop sources>> push ]
  73     [
  74         CFRunLoopGetMain
  75         swap CFRunLoopDefaultMode
  76         CFRunLoopAddSource
  77     ] bi ;
  78
  79 : create-fd-source ( CFFileDescriptor -- source )
  80     f swap 0 CFFileDescriptorCreateRunLoopSource ;
  81
  82 : add-fd-to-run-loop ( fd callback -- )
  83     [
  84         <CFFileDescriptor> |CFRelease
  85         [ run-loop fds>> push ]
  86         [ create-fd-source |CFRelease add-source-to-run-loop ]
  87         bi
  88     ] with-destructors ;
  89
  90 : add-timer-to-run-loop ( timer -- )
  91     [ run-loop timers>> push ]
  92     [
  93         CFRunLoopGetMain
  94         swap CFRunLoopDefaultMode
  95         CFRunLoopAddTimer
  96     ] bi ;
  97
  98 <PRIVATE
  99
 100 : ((reset-timer)) ( timer counter timestamp -- )
 101     nip >CFAbsoluteTime CFRunLoopTimerSetNextFireDate ;
 102
 103 : (reset-timer) ( timer counter -- )
 104     yield {
 105         { [ dup 0 = ] [ now ((reset-timer)) ] }
 106         { [ run-queue deque-empty? not ] [ 1 - (reset-timer) ] }
 107         { [ sleep-queue heap-empty? ] [ 5 minutes hence ((reset-timer)) ] }
 108         [ sleep-queue heap-peek nip micros>timestamp ((reset-timer)) ]
 109     } cond ;
 110
 111 : reset-timer ( timer -- )
 112     10 (reset-timer) ;
 113
 114 PRIVATE>
 115
 116 : reset-run-loop ( -- )
 117     run-loop
 118     [ timers>> [ reset-timer ] each ]
 119     [ fds>> [ enable-all-callbacks ] each ] bi ;
 120
 121 : timer-callback ( -- callback )
 122     "void" { "CFRunLoopTimerRef" "void*" } "cdecl"
 123     [ 2drop reset-run-loop yield ] alien-callback ;
 124
 125 : init-thread-timer ( -- )
 126     timer-callback <CFTimer> add-timer-to-run-loop ;
 127
 128 : run-one-iteration ( us -- handled? )
 129     reset-run-loop
 130     CFRunLoopDefaultMode
 131     swap [ microseconds ] [ 5 minutes ] if* >CFTimeInterval
 132     t CFRunLoopRunInMode kCFRunLoopRunHandledSource = ;