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


# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and
# modify it under the terms of the GNU General Public Licens
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be us
# but WITHOUT ANY WARRANTY; without even the implied warrant
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See 
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public 
# version 2 along with this program; if not, write to the Fr
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 


constant has_user_field true


if os_api="linux"
  constant pliant_suspend_signal os_SIGUSR1
if os_api="linux"
  constant pliant_suspend_signal os_SIGUSR1
  public
    gvar Address stack_base
    gvar Int stack_size := 1024*2^10
  constant thread_trace false
  constant thread_trace false
  public
    constant stack_size 1024*2^10 # must match start.s
    gvar Int stack_base


  function compute_stack_base
    var Int a_variable_on_the_stack
    stack_base := cast (cast addressof:a_variable_on_the_sta
    memory_limit_address := stack_base translate Byte -stack
  compute_stack_base



type ThreadHeader
  field Address variables_context
type ThreadHeader
  field Address variables_context
  field Int language_index
  if has_user_field
    field Str user
  if os_api="linux"
    field Int pid
  eif os_api="os2"
    field Int tid
  eif os_api="posix"
    field Int id
  eif os_api="win32"
    field Int handle
  field Int priority
  field Int restart_cost
  field Pointer:ThreadHeader next
  field DelayedAction action
  field Address address # used by 'execute'
  field Pointer:ThreadHeader list_next list_previous
  field FastSem action_sem
  field Pointer:ActionRecord top_action
  field Pointer:ErrorRecord top_error
  field ErrorRecord bottom_error
  if processor_is_pentium
    field uInt processor_counter_low processor_counter_high

  if os_api="linux"
    field Int pid
  eif os_api="os2"
    field Int tid
  eif os_api="posix"
    field Int id
  eif os_api="win32"
    field Int handle
  field Int priority
  field Int restart_cost
  field Pointer:ThreadHeader next
  field DelayedAction action
  field Address address # used by 'execute'
  field Pointer:ThreadHeader list_next list_previous
  field FastSem action_sem
  field Pointer:ActionRecord top_action
  field Pointer:ErrorRecord top_error
  field ErrorRecord bottom_error
  if processor_is_pentium
    field uInt processor_counter_low processor_counter_high

export ThreadHeader '. variables_context' '. address'
if os_api="linux"
  check ThreadHeader:size<=256 # must match start.s

export ThreadHeader '. variables_context' '. language_index' '. address'
export '. list_next' '. action_sem' '. top_action'
export '. list_next' '. action_sem' '. top_action'
if has_user_field
  export '. user'
if os_api="linux"
  export '. pid'
eif os_api="os2"
  export '. tid'
if processor_is_pentium
  export '. processor_counter_low' '. processor_counter_high


method h setup
  arg_rw ThreadHeader h
if os_api="linux"
  export '. pid'
eif os_api="os2"
  export '. tid'
if processor_is_pentium
  export '. processor_counter_low' '. processor_counter_high


method h setup
  arg_rw ThreadHeader h
  h language_index := 0
  if has_user_field
    Str build_instance (addressof h:user)
  h top_action :> null map ActionRecord
  h:bottom_error id := error_id_noerror
  h:bottom_error filter := error_filter_none
  h:bottom_error next :> null map ErrorRecord
  h top_error :> h bottom_error



  function allocate_stack -> h
    arg_RW ThreadHeader h
    threads_sem request
    if addressof:first_available<>null
      h :> first_available ; first_available :> h next
      threads_sem release
    else
  h top_action :> null map ActionRecord
  h:bottom_error id := error_id_noerror
  h:bottom_error filter := error_filter_none
  h:bottom_error next :> null map ErrorRecord
  h top_error :> h bottom_error



  function allocate_stack -> h
    arg_RW ThreadHeader h
    threads_sem request
    if addressof:first_available<>null
      h :> first_available ; first_available :> h next
      threads_sem release
    else
      var Address bottom := stack_base translate Byte -threa
      var Address bottom := cast stack_base.-.thread_stacks_count*stack_size Address
      if (cast bottom uInt)<(cast memory_base_address uInt)
        error_notify_fatal error_id_memory_starvation "Out o
      memory_limit_address := bottom
      thread_stacks_count := thread_stacks_count+1
      threads_sem release
      var Address got := os_mmap bottom stack_size os_PROT_R
      if got<>(cast -1 Address)
        h :> ((bottom translate Byte stack_size) translate T
        h pid := 0
      else
        h :> null map ThreadHeader


if os_api="linux"
      if (cast bottom uInt)<(cast memory_base_address uInt)
        error_notify_fatal error_id_memory_starvation "Out o
      memory_limit_address := bottom
      thread_stacks_count := thread_stacks_count+1
      threads_sem release
      var Address got := os_mmap bottom stack_size os_PROT_R
      if got<>(cast -1 Address)
        h :> ((bottom translate Byte stack_size) translate T
        h pid := 0
      else
        h :> null map ThreadHeader


if os_api="linux"

  gvar ThreadHeader first_thread_header
  gvar Int first_thread_stack_top

 
  function current_thread_header -> h
    arg_RW ThreadHeader h
    has_side_effects
    var Int esp := i386_register i386_esp
  function current_thread_header -> h
    arg_RW ThreadHeader h
    has_side_effects
    var Int esp := i386_register i386_esp
    var Int stack_top := (esp .+. stack_size .-. 1) .and. .n
    if stack_top=first_thread_stack_top
      h :> first_thread_header
    else
      h :> (((cast stack_top Address) translate ThreadHeader
    var Int stack_bottom := esp .and. .not. (cast stack_size-1 Int)
    h :> (cast stack_bottom .+. (stack_size-ThreadHeader:size) Address) map ThreadHeader

  function set_first_thread_info p fh
    arg Address p ; arg Int fh
    var Int esp := i386_register i386_esp

  function set_first_thread_info p fh
    arg Address p ; arg Int fh
    var Int esp := i386_register i386_esp
    first_thread_stack_top := (esp .+. stack_size .-. 1) .an
    first_thread_header pid := os_getpid
    stack_base := esp .and. .not. (cast stack_size-1 Int)
    var Pointer:ThreadHeader h :> current_thread_header
    h setup
    h pid := os_getpid
    #
    thread_stacks_count := 1
    first_zombie :> null map ThreadHeader
    first_available :> null map ThreadHeader
    recycling_first :> null map ThreadHeader
  set_first_thread_info null 0
  gvar DelayedAction da1
  da1 function :> the_function set_first_thread_info Address
  pliant_restore_actions insert_before pliant_restore_action


    function run_thread action -> success
      arg DelayedAction action ; arg CBool success
      if thread_trace
        console "run "+action:function:position+"[lf]"
      recycling_sem request
      if exists:recycling_first
        var Pointer:ThreadHeader h :> recycling_first
        recycling_first :> h next
        recycling_sem release
    #
    thread_stacks_count := 1
    first_zombie :> null map ThreadHeader
    first_available :> null map ThreadHeader
    recycling_first :> null map ThreadHeader
  set_first_thread_info null 0
  gvar DelayedAction da1
  da1 function :> the_function set_first_thread_info Address
  pliant_restore_actions insert_before pliant_restore_action


    function run_thread action -> success
      arg DelayedAction action ; arg CBool success
      if thread_trace
        console "run "+action:function:position+"[lf]"
      recycling_sem request
      if exists:recycling_first
        var Pointer:ThreadHeader h :> recycling_first
        recycling_first :> h next
        recycling_sem release
        var Pointer:ThreadHeader cth :> current_thread_header
        h variables_context := cth variables_context
        h language_index := cth language_index
        if has_user_field
          h user := cth user
        h action := action
        restart_thread h
        return true
      recycling_sem release
      terminate_zombies
      atomic_add current_running_threads 1
      maximum_running_threads := max maximum_running_threads
      var Pointer:ThreadHeader h :> allocate_stack
      if not exists:h
        atomic_add current_running_threads -1
        return false
        h action := action
        restart_thread h
        return true
      recycling_sem release
      terminate_zombies
      atomic_add current_running_threads 1
      maximum_running_threads := max maximum_running_threads
      var Pointer:ThreadHeader h :> allocate_stack
      if not exists:h
        atomic_add current_running_threads -1
        return false
      h variables_context := current_thread_header variables
      h setup
      var Pointer:ThreadHeader cth :> current_thread_header
      h variables_context := cth variables_context
      h language_index := cth language_index
      if has_user_field
        h user := cth user
      DelayedAction build_instance (addressof h:action)
      ErrorRecord build_instance (addressof h:bottom_error)
      h action := action
      DelayedAction build_instance (addressof h:action)
      ErrorRecord build_instance (addressof h:bottom_error)
      h action := action
      h setup      
      var Int pid := os_clone 8F00h (addressof:h translate B
      if pid=0
        h :> current_thread_header
        h pid := os_getpid
        os_sigsetmask 2^(pliant_suspend_signal-1)
        thread_insert_header h
        execute1 h:action:parameter h:action:function
        error_report
        while pliant_execution_phase<=execution_phase_run an
          DelayedAction destroy_instance (addressof h:action
          DelayedAction build_instance (addressof h:action)
          ActionRecord build_instance addressof:(var ActionR
          action_push_record (var ActionRecord ar) "recyclin
          recycling_sem request
          h next :> recycling_first
          recycling_first :> h
          recycling_sem release
          stop_current_thread
          action_pull_record ar
          ActionRecord destroy_instance addressof:ar
          if (exists h:action:function)
            execute1 h:action:parameter h:action:function
          error_report
        thread_remove_header h
        ErrorRecord destroy_instance (addressof h:bottom_err
        record_zombie h
        atomic_add current_running_threads -1
        os_exit 0
      eif pid=(-1)
        DelayedAction destroy_instance (addressof h:action)
        free_stack h
        atomic_add current_running_threads -1
        return false
      else
        return true


    function run_thread action -> success
      arg DelayedAction action ; arg CBool success
      terminate_zombies
      atomic_add current_running_threads 1
      maximum_running_threads := max maximum_running_threads
      var Pointer:ThreadHeader h :> new ThreadHeader ; entry
      var Int pid := os_clone 8F00h (addressof:h translate B
      if pid=0
        h :> current_thread_header
        h pid := os_getpid
        os_sigsetmask 2^(pliant_suspend_signal-1)
        thread_insert_header h
        execute1 h:action:parameter h:action:function
        error_report
        while pliant_execution_phase<=execution_phase_run an
          DelayedAction destroy_instance (addressof h:action
          DelayedAction build_instance (addressof h:action)
          ActionRecord build_instance addressof:(var ActionR
          action_push_record (var ActionRecord ar) "recyclin
          recycling_sem request
          h next :> recycling_first
          recycling_first :> h
          recycling_sem release
          stop_current_thread
          action_pull_record ar
          ActionRecord destroy_instance addressof:ar
          if (exists h:action:function)
            execute1 h:action:parameter h:action:function
          error_report
        thread_remove_header h
        ErrorRecord destroy_instance (addressof h:bottom_err
        record_zombie h
        atomic_add current_running_threads -1
        os_exit 0
      eif pid=(-1)
        DelayedAction destroy_instance (addressof h:action)
        free_stack h
        atomic_add current_running_threads -1
        return false
      else
        return true


    function run_thread action -> success
      arg DelayedAction action ; arg CBool success
      terminate_zombies
      atomic_add current_running_threads 1
      maximum_running_threads := max maximum_running_threads
      var Pointer:ThreadHeader h :> new ThreadHeader ; entry
      h variables_context := current_thread_header variables
      h action := action
      h setup
      h setup
      var Pointer:ThreadHeader cth :> current_thread_header
      h variables_context := cth variables_context
      h language_index := cth language_index
      if has_user_field
        h user := cth user
      h action := action
      success := (pthread_create (var Int handle) null (the_
      if not success
        atomic_add current_running_threads -1
        entry_unlock addressof:h


  function run_thread action -> success
    arg DelayedAction action ; arg CBool success
    terminate_zombies
    atomic_add current_running_threads 1
    maximum_running_threads := max maximum_running_threads c
    var Pointer:ThreadHeader h :> new ThreadHeader ; entry_l
      success := (pthread_create (var Int handle) null (the_
      if not success
        atomic_add current_running_threads -1
        entry_unlock addressof:h


  function run_thread action -> success
    arg DelayedAction action ; arg CBool success
    terminate_zombies
    atomic_add current_running_threads 1
    maximum_running_threads := max maximum_running_threads c
    var Pointer:ThreadHeader h :> new ThreadHeader ; entry_l
    h variables_context := current_thread_header variables_c
    h action := action
    h setup
    h setup
    var Pointer:ThreadHeader cth :> current_thread_header
    h variables_context := cth variables_context
    h language_index := cth language_index
    if has_user_field
      h user := cth user
    h action := action
    h handle := -1
    h handle := os_CreateThread null 0 (the_function thread_
    success := h:handle<>0
    if not success
      atomic_add current_running_threads -1
      entry_unlock addressof:h


  function run_thread action -> success
    arg DelayedAction action ; arg CBool success
    terminate_zombies
    atomic_add current_running_threads 1
    maximum_running_threads := max maximum_running_threads c
    var Pointer:ThreadHeader h :> new ThreadHeader ; entry_l
    h handle := -1
    h handle := os_CreateThread null 0 (the_function thread_
    success := h:handle<>0
    if not success
      atomic_add current_running_threads -1
      entry_unlock addressof:h


  function run_thread action -> success
    arg DelayedAction action ; arg CBool success
    terminate_zombies
    atomic_add current_running_threads 1
    maximum_running_threads := max maximum_running_threads c
    var Pointer:ThreadHeader h :> new ThreadHeader ; entry_l
    h variables_context := current_thread_header variables_c
    h action := action
    h setup
    h setup
    var Pointer:ThreadHeader cth :> current_thread_header
    h variables_context := cth variables_context
    h language_index := cth language_index
    if has_user_field
      h user := cth user
    h action := action
    success := (os_DosCreateThread (var Int tid) (the_functi
    if not success
      atomic_add current_running_threads -1
      entry_unlock addressof:h


    success := (os_DosCreateThread (var Int tid) (the_functi
    if not success
      atomic_add current_running_threads -1
      entry_unlock addressof:h


if os_api="linux" or os_api="posix" or os_api="win32" or os_
if os_api="posix" or os_api="win32" or os_api="os2"
  if addressof:current_thread_header<>addressof:first_thread
    error error_id_os "Threads interface seems to be buggy u



  function back_to_single_thread
    var Int me := os_getpid
  if addressof:current_thread_header<>addressof:first_thread
    error error_id_os "Threads interface seems to be buggy u



  function back_to_single_thread
    var Int me := os_getpid
    for (var Int i) 1 thread_stacks_count-1
      var Address bottom := stack_base translate Byte -i*sta
      var Pointer:ThreadHeader h :> ((bottom translate Byte 
      var Int pid := h pid
      if pid<>me and pid>0
        os_kill pid os_SIGKILL
    pid := first_thread_header pid
    if pid<>me and pid>0
      os_kill pid os_SIGKILL
    for (var Int i) thread_stacks_count-1 0 step -1
      var Int bottom := stack_base.-.i*stack_size
      var Pointer:ThreadHeader h :> (cast bottom .+. (stack_size-ThreadHeader:size) Address) map ThreadHeader
      if h:pid<>me and h:pid>0
        os_kill h:pid os_SIGKILL
    memory_semaphore_address map Int := 0
    if pliant_c_debugging_level>=2
      pliant_entry_lock_hook := the_function:nolock executab


    memory_semaphore_address map Int := 0
    if pliant_c_debugging_level>=2
      pliant_entry_lock_hook := the_function:nolock executab