/pliant/language/schedule/sem.pli
 
 1  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 2  # 
 3  # This program is free software; you can redistribute it and/or 
 4  # modify it under the terms of the GNU General Public License version 2 
 5  # as published by the Free Software Foundation. 
 6  # 
 7  # This program is distributed in the hope that it will be useful, 
 8  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 9  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 10  # GNU General Public License for more details. 
 11  # 
 12  # You should have received a copy of the GNU General Public License 
 13  # version 2 along with this program; if not, write to the Free Software 
 14  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 15   
 16  scope "/pliant/language/" "/pliant/install/" 
 17  module "/pliant/install/ring2.pli" 
 18  module "pentium.pli" 
 19   
 20   
 21  constant trivial_yield_policy processor_count>1 
 22  constant not_too_unfair true 
 23   
 24  constant slice_fill processor_is_pentium and processor_count>1 
 25  constant slice_cycles 2^20 # number of processor cycles per time slice 
 26   
 27  constant busy_wait false 
 28  constant busy_sleep 2^9 
 29  constant busy_timeout 2^12 
 30   
 31   
 32  if slice_fill 
 33   
 34    function set_slice 
 35      var Pointer:ThreadHeader h :> current_thread_header 
 36      pentium_counter h:processor_counter_low h:processor_counter_high 
 37   
 38    function same_slice -> c 
 39      arg CBool c 
 40      pentium_counter (var uInt low) (var uInt high) 
 41      var Pointer:ThreadHeader h :> current_thread_header 
 42      c := ( high=h:processor_counter_high or (high .-. h:processor_counter_high)=1 and low<h:processor_counter_low ) and (low .-. h:processor_counter_low)<slice_cycles 
 43         
 44  else 
 45   
 46    function set_slice 
 47      void 
 48   
 49    constant same_slice false 
 50   
 51   
 52  constant not_locked 0 
 53  constant write_locked 80000000h 
 54  constant please_retry 0FFFFFFFFh 
 55   
 56  constant high_cost 1000000000 
 57   
 58   
 59  type Sem 
 60    field uInt status 
 61    if trivial_yield_policy 
 62      if not_too_unfair 
 63        field CBool please_schedule 
 64    else 
 65      field ThreadQueue queue 
 66     
 67   
 68  function build sem 
 69    arg_w Sem sem 
 70    sem status := not_locked 
 71    if trivial_yield_policy and not_too_unfair 
 72      sem please_schedule := false 
 73   
 74  if pliant_debugging_level>=2 
 75    function destroy sem 
 76      arg_w Sem sem 
 77      if trivial_yield_policy 
 78        check sem:status=0 or pliant_execution_phase>execution_phase_run "Attempted to destroy a locked semaphore" 
 79      else 
 80        check (sem:status=0 and sem:queue:is_empty) or pliant_execution_phase>execution_phase_run "Attempted to destroy a locked semaphore" 
 81   
 82   
 83  if not trivial_yield_policy 
 84    method sem safe_read_status -> s 
 85      arg_rw Sem sem ; arg uInt s 
 86      if busy_wait 
 87        while true 
 88          s := atomic_read_and_set sem:status please_retry 
 89          if s<>please_retry 
 90            return 
 91          pentium_counter (var uInt start_low) (var uInt start_high) 
 92          while { pentium_counter (var uInt lap_low) (var uInt lap_high) ; ( lap_high=start_high or (lap_high .-. start_high)=1 and lap_low<start_low ) and (lap_low .-. start_low)<busy_timeout } 
 93            while { pentium_counter (var uInt low) (var uInt high) ; ( high=lap_high or (high .-. lap_high)=1 and low<lap_low ) and (low .-. lap_low)<busy_sleep } 
 94              void # the busy loop 
 95            s := atomic_read_and_set sem:status please_retry 
 96            if s<>please_retry 
 97              return 
 98          os_yield # timeout 
 99      else 
 100        while { := atomic_read_and_set sem:status please_retry ; s=please_retry } 
 101          os_yield 
 102   
 103  method sem request 
 104    arg_rw Sem sem 
 105    if trivial_yield_policy 
 106      if not_too_unfair and sem:please_schedule and not same_slice 
 107        os_yield 
 108      while true 
 109        var uInt s := atomic_read_and_set sem:status please_retry 
 110        if s=not_locked 
 111          sem status := write_locked 
 112          if not_too_unfair 
 113            sem please_schedule := false 
 114          return 
 115        if s<>please_retry 
 116          sem status := s 
 117        os_yield ; set_slice 
 118        if not_too_unfair 
 119          sem please_schedule := true 
 120    else 
 121      var uInt := sem safe_read_status 
 122      if s<>not_locked or not sem:queue:is_empty and not same_slice 
 123        sem:queue add_current_thread 0 high_cost 
 124        sem status := s 
 125        stop_current_thread 
 126        set_slice 
 127        := sem safe_read_status 
 128        while s<>not_locked 
 129          sem:queue add_current_thread 0 high_cost 
 130          sem status := s 
 131          stop_current_thread 
 132          set_slice 
 133          := sem safe_read_status 
 134      sem status := write_locked 
 135   
 136   
 137  method sem release 
 138    arg_rw Sem sem 
 139    if trivial_yield_policy 
 140      while (var uInt s := atomic_read_and_set sem:status please_retry ; s=please_retry) 
 141        os_yield 
 142      check s=write_locked "Attempted to write realease a not write locked semaphore" 
 143      sem status := not_locked 
 144    else 
 145      var uInt := sem safe_read_status 
 146      check s=write_locked "Attempted to write realease a not write locked semaphore" 
 147      sem:queue restart_some_threads high_cost sem:status not_locked 
 148   
 149   
 150  method sem rd_request 
 151    arg_rw Sem sem 
 152    if trivial_yield_policy 
 153      if not_too_unfair and sem:please_schedule and not same_slice 
 154        os_yield 
 155      while true 
 156        var uInt s := atomic_read_and_set sem:status please_retry 
 157        if s<>please_retry and s<>write_locked 
 158          sem status := s+1 
 159          if not_too_unfair 
 160            sem please_schedule := false 
 161          return 
 162        if s<>please_retry 
 163          sem status := s 
 164        os_yield ; set_slice 
 165        if not_too_unfair 
 166          sem please_schedule := true 
 167    else 
 168      var uInt := sem safe_read_status 
 169      if s=write_locked or not sem:queue:is_empty and not same_slice 
 170        sem:queue add_current_thread 0 1 
 171        sem status := s 
 172        stop_current_thread 
 173        set_slice 
 174        := sem safe_read_status 
 175        while s=write_locked 
 176          sem:queue add_current_thread 0 1 
 177          sem status := s 
 178          stop_current_thread 
 179          set_slice 
 180          := sem safe_read_status 
 181      sem status := s+1 
 182       
 183   
 184  method sem rd_release 
 185    arg_rw Sem sem 
 186    if trivial_yield_policy 
 187      while (var uInt s := atomic_read_and_set sem:status please_retry ; s=please_retry) 
 188        os_yield 
 189      check s>0 and s<>write_locked "Attempted to read realease a not read locked semaphore" 
 190      sem status := s-1 
 191    else 
 192      var uInt := sem safe_read_status 
 193      check s>and s<>write_locked "Attempted to read realease a not read locked semaphore" 
 194      if s=and not sem:queue:is_empty 
 195        sem:queue restart_some_threads high_cost sem:status s-1 
 196      else 
 197        sem status := s-1 
 198   
 199   
 200  method sem nowait_request -> success 
 201    arg_rw Sem sem ; arg CBool success 
 202    if trivial_yield_policy 
 203      var uInt s := atomic_read_and_set sem:status please_retry 
 204      if s=not_locked 
 205        sem status := write_locked 
 206        success := true 
 207      else 
 208        if s<>please_retry 
 209          sem status := s 
 210        success := false 
 211    else 
 212      var uInt := sem safe_read_status 
 213      if s=not_locked and sem:queue:is_empty 
 214        sem status := write_locked 
 215        success := true 
 216      else 
 217        sem status := s 
 218        success := false 
 219        
 220   
 221  method sem nowait_rd_request -> success 
 222    arg_rw Sem sem ; arg CBool success 
 223    if trivial_yield_policy 
 224      var uInt s := atomic_read_and_set sem:status please_retry 
 225      if s<>write_locked and s<>please_retry 
 226        sem status := s+1 
 227        success := true 
 228      else 
 229        if s<>please_retry 
 230          sem status := s 
 231        success := false 
 232    else 
 233      var uInt := sem safe_read_status 
 234      if s<>write_locked and sem:queue:is_empty 
 235        sem status := s+1 
 236        success := true 
 237      else 
 238        sem status := s 
 239        success := false 
 240   
 241     
 242  export Sem '. request' '. release' '. rd_request' '. rd_release' '. nowait_request' '. nowait_rd_request' 
 243