Patch title: Release 84 bulk changes
Abstract:
File: /pliant/language/schedule/sem.pli
Key:
    Removed line
    Added line
# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License version 2
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# version 2 along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

scope "/pliant/language/" "/pliant/install/"
module "/pliant/install/ring2.pli"
module "pentium.pli"


constant trivial_yield_policy processor_count>1
constant not_too_unfair true

constant slice_fill processor_is_pentium and processor_count>1
constant slice_cycles 2^20 # number of processor cycles per time slice

constant busy_wait false
constant busy_sleep 2^9
constant busy_timeout 2^12


if slice_fill

  function set_slice
    var Pointer:ThreadHeader h :> current_thread_header
    pentium_counter h:processor_counter_low h:processor_counter_high

  function same_slice -> c
    arg CBool c
    pentium_counter (var uInt low) (var uInt high)
    var Pointer:ThreadHeader h :> current_thread_header
    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
      
else

  function set_slice
    void

  constant same_slice false


constant not_locked 0
constant write_locked 80000000h
constant please_retry 0FFFFFFFFh

constant high_cost 1000000000


type Sem
  field uInt status
  if trivial_yield_policy
    if not_too_unfair
      field CBool please_schedule
  else
    field ThreadQueue queue
  

function build sem
  arg_w Sem sem
  sem status := not_locked
  if trivial_yield_policy and not_too_unfair
    sem please_schedule := false

if pliant_debugging_level>=2
  function destroy sem
    arg_w Sem sem
    if trivial_yield_policy
      check sem:status=0 or pliant_execution_phase>execution_phase_run "Attempted to destroy a locked semaphore"
    else
      check (sem:status=0 and sem:queue:is_empty) or pliant_execution_phase>execution_phase_run "Attempted to destroy a locked semaphore"


if not trivial_yield_policy
  method sem safe_read_status -> s
    arg_rw Sem sem ; arg uInt s
    if busy_wait
      while true
        s := atomic_read_and_set sem:status please_retry
        if s<>please_retry
          return
        pentium_counter (var uInt start_low) (var uInt start_high)
        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 }
          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 }
            void # the busy loop
          s := atomic_read_and_set sem:status please_retry
          if s<>please_retry
            return
        os_yield # timeout
    else
      while { s := atomic_read_and_set sem:status please_retry ; s=please_retry }
        os_yield

method sem request
  arg_rw Sem sem
  if trivial_yield_policy
    if not_too_unfair and sem:please_schedule and not same_slice
      os_yield
    while true
      var uInt s := atomic_read_and_set sem:status please_retry
      if s=not_locked
        sem status := write_locked
        if not_too_unfair
          sem please_schedule := false
        return
      if s<>please_retry
        sem status := s
      os_yield ; set_slice
      if not_too_unfair
        sem please_schedule := true
  else
    var uInt s := sem safe_read_status
    if s<>not_locked or not sem:queue:is_empty and not same_slice
      sem:queue add_current_thread 0 high_cost
      sem status := s
      stop_current_thread
      set_slice
      s := sem safe_read_status
      while s<>not_locked
        sem:queue add_current_thread 0 high_cost
        sem status := s
        stop_current_thread
        set_slice
        s := sem safe_read_status
    sem status := write_locked


method sem release
  arg_rw Sem sem
  if trivial_yield_policy
    while (var uInt s := atomic_read_and_set sem:status please_retry ; s=please_retry)
      os_yield
    check s=write_locked "Attempted to write realease a not write locked semaphore"
    sem status := not_locked
  else
    var uInt s := sem safe_read_status
    check s=write_locked "Attempted to write realease a not write locked semaphore"
    sem:queue restart_some_threads high_cost sem:status not_locked


method sem rd_request
  arg_rw Sem sem
  if trivial_yield_policy
    if not_too_unfair and sem:please_schedule and not same_slice
      os_yield
    while true
      var uInt s := atomic_read_and_set sem:status please_retry
      if s<>please_retry and s<>write_locked
        sem status := s+1
        if not_too_unfair
          sem please_schedule := false
        return
      if s<>please_retry
        sem status := s
      os_yield ; set_slice
      if not_too_unfair
        sem please_schedule := true
  else
    var uInt s := sem safe_read_status
    if s=write_locked or not sem:queue:is_empty and not same_slice
      sem:queue add_current_thread 0 1
      sem status := s
      stop_current_thread
      set_slice
      s := sem safe_read_status
      while s=write_locked
        sem:queue add_current_thread 0 1
        sem status := s
        stop_current_thread
        set_slice
        s := sem safe_read_status
    sem status := s+1
    

method sem rd_release
  arg_rw Sem sem
  if trivial_yield_policy
    while (var uInt s := atomic_read_and_set sem:status please_retry ; s=please_retry)
      os_yield
    check s>0 and s<>write_locked "Attempted to read realease a not read locked semaphore"
    sem status := s-1
  else
    var uInt s := sem safe_read_status
    check s>0 and s<>write_locked "Attempted to read realease a not read locked semaphore"
    if s=1 and not sem:queue:is_empty
      sem:queue restart_some_threads high_cost sem:status s-1
    else
      sem status := s-1


method sem nowait_request -> success
  arg_rw Sem sem ; arg CBool success
  if trivial_yield_policy
    var uInt s := atomic_read_and_set sem:status please_retry
    if s=not_locked
      sem status := write_locked
      success := true
    else
      if s<>please_retry
        sem status := s
      success := false
  else
    var uInt s := sem safe_read_status
    if s=not_locked and sem:queue:is_empty
      sem status := write_locked
      success := true
    else
      sem status := s
      success := false
     

method sem nowait_rd_request -> success
  arg_rw Sem sem ; arg CBool success
  if trivial_yield_policy
    var uInt s := atomic_read_and_set sem:status please_retry
    if s<>write_locked and s<>please_retry
      sem status := s+1
      success := true
    else
      if s<>please_retry
        sem status := s
      success := false
  else
    var uInt s := sem safe_read_status
    if s<>write_locked and sem:queue:is_empty
      sem status := s+1
      success := true
    else
      sem status := s
      success := false
     

  
export Sem '. request' '. release' '. rd_request' '. rd_release' '. nowait_request' '. nowait_rd_request'