/pliant/language/schedule/threads_engine.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/" 
 17  module "/pliant/install/ring2.pli" 
 18  module "pentium.pli" 
 19   
 20  constant has_user_field true 
 21   
 22   
 23  if os_api="linux" 
 24    constant pliant_suspend_signal os_SIGUSR1 
 25    constant thread_trace false 
 26    public 
 27      constant stack_size 1024*2^10 # must match start.s 
 28      gvar Int stack_base 
 29   
 30   
 31  type ThreadHeader 
 32    field Address variables_context 
 33    field Int language_index 
 34    if has_user_field 
 35      field Str user 
 36    if os_api="linux" 
 37      field Int pid 
 38    eif os_api="os2" 
 39      field Int tid 
 40    eif os_api="posix" 
 41      field Int id 
 42    eif os_api="win32" 
 43      field Int handle 
 44    field Int priority 
 45    field Int restart_cost 
 46    field Pointer:ThreadHeader next 
 47    field DelayedAction action 
 48    field Address address # used by 'execute' 
 49    field Pointer:ThreadHeader list_next list_previous 
 50    field FastSem action_sem 
 51    field Pointer:ActionRecord top_action 
 52    field Pointer:ErrorRecord top_error 
 53    field ErrorRecord bottom_error 
 54    if processor_is_pentium 
 55      field uInt processor_counter_low processor_counter_high 
 56   
 57  if os_api="linux" 
 58    check ThreadHeader:size<=256 # must match start.s 
 59   
 60  export ThreadHeader '. variables_context' '. language_index' '. address' 
 61  export '. list_next' '. action_sem' '. top_action' 
 62  if has_user_field 
 63    export '. user' 
 64  if os_api="linux" 
 65    export '. pid' 
 66  eif os_api="os2" 
 67    export '. tid' 
 68  if processor_is_pentium 
 69    export '. processor_counter_low' '. processor_counter_high' 
 70   
 71   
 72  method h setup 
 73    arg_rw ThreadHeader h 
 74    language_index := 0 
 75    if has_user_field 
 76      Str build_instance (addressof h:user) 
 77    top_action :> null map ActionRecord 
 78    h:bottom_error id := error_id_noerror 
 79    h:bottom_error filter := error_filter_none 
 80    h:bottom_error next :> null map ErrorRecord 
 81    top_error :> bottom_error 
 82   
 83   
 84  public 
 85    gvar FastSem thread_list_sem 
 86    gvar ThreadHeader thread_list_pivot 
 87  thread_list_pivot list_next :> thread_list_pivot ; thread_list_pivot list_previous :> thread_list_pivot 
 88   
 89  function thread_insert_header h 
 90    arg_rw ThreadHeader h 
 91    thread_list_sem request 
 92    list_next :> thread_list_pivot list_next 
 93    list_previous :> thread_list_pivot 
 94    thread_list_pivot:list_next list_previous :> h 
 95    thread_list_pivot list_next :> h 
 96    thread_list_sem release 
 97   
 98  function thread_remove_header h 
 99    arg_rw ThreadHeader h 
 100    thread_list_sem request 
 101    h:list_previous list_next :> list_next 
 102    h:list_next list_previous :> list_previous 
 103    thread_list_sem release 
 104   
 105   
 106 
 
 107  #  starting and stopping threads 
 108   
 109   
 110  if os_api="linux" 
 111   
 112    if false 
 113   
 114      function stop_current_thread 
 115        os_kill current_thread_header:pid os_SIGSTOP 
 116   
 117      function restart_thread h 
 118        arg ThreadHeader h 
 119        os_kill h:pid os_SIGCONT 
 120   
 121    else 
 122   
 123      function stop_current_thread 
 124        os_sigsuspend 0 0 .not. (2^(pliant_suspend_signal-1) .or. 2^(os_SIGINT-1) .or. 2^(os_SIGTERM-1) .or. 2^(os_SIGKILL-1)) 
 125        os_sigsetmask 2^(pliant_suspend_signal-1) 
 126   
 127      function restart_thread h 
 128        arg ThreadHeader h 
 129        os_kill h:pid pliant_suspend_signal 
 130   
 131      function exception_handler3 num 
 132        arg Int num 
 133        external_calling_convention 
 134      gvar os_sigaction sa3 
 135      sa3 sa_handler := (the_function exception_handler3 Int) executable 
 136      entry_root addressof:(the_function exception_handler3 Int) 
 137      function record_exception_handler3 parameter filehandle 
 138        arg Address parameter ; arg Int filehandle 
 139        if (os_sigaction pliant_suspend_signal sa3 (null map os_sigaction))<>0 
 140          error error_id_os "Failed to install Linux pliant_suspend_signal exception handler" 
 141      record_exception_handler3 null 0 
 142      gvar DelayedAction da3 
 143      da3 function :> the_function record_exception_handler3 Address Int 
 144      pliant_restore_actions append addressof:da3 
 145   
 146  eif os_api="posix" 
 147   
 148    function pthread_self -> handle 
 149      arg Int handle 
 150      external os_libpthread_filename "pthread_self" 
 151   
 152    function pthread_kill handle signal -> err 
 153      arg Int handle signal err 
 154      external os_libpthread_filename "pthread_kill" 
 155   
 156    function stop_current_thread 
 157      pthread_kill pthread_self os_SIGSTOP 
 158   
 159    function restart_thread h 
 160      arg ThreadHeader h 
 161      pthread_kill h:id os_SIGCONT 
 162   
 163  eif os_api="win32" 
 164   
 165    gvar Int tls 
 166   
 167    function current_thread_header -> h 
 168      arg_RW ThreadHeader h 
 169      h :> os_TlsGetValue:tls map ThreadHeader 
 170   
 171    function stop_current_thread 
 172      var Pointer:ThreadHeader h :> current_thread_header 
 173      while h:handle=(-1) 
 174        os_yield 
 175      os_SuspendThread h:handle 
 176   
 177    function restart_thread h 
 178      arg ThreadHeader h 
 179      while (os_ResumeThread h:handle)<=0 
 180        os_yield 
 181   
 182  eif os_api="os2" 
 183   
 184    function stop_current_thread 
 185      os_DosSuspendThread current_thread_header:tid 
 186   
 187    function restart_thread h 
 188      arg ThreadHeader h 
 189      while (os_DosResumeThread h:tid)=ERROR_NOT_FROZEN 
 190        os_yield 
 191   
 192   
 193 
 
 194  #  allocating thread stacks 
 195   
 196  if os_api="linux" 
 197   
 198    public 
 199      gvar Int thread_stacks_count := 1 
 200    gvar FastSem threads_sem 
 201    gvar Pointer:ThreadHeader first_zombie :> null map ThreadHeader 
 202    gvar Pointer:ThreadHeader first_available :> null map ThreadHeader 
 203   
 204    gvar Pointer:ThreadHeader recycling_first :> null map ThreadHeader 
 205    gvar FastSem recycling_sem 
 206   
 207    function record_zombie h 
 208      arg_rw ThreadHeader h 
 209      threads_sem request 
 210      next :> first_zombie ; first_zombie :> h 
 211      threads_sem release 
 212   
 213    function terminate_zombies 
 214      if addressof:first_zombie=null 
 215        return 
 216      var Pointer:ThreadHeader lost :> null map ThreadHeader 
 217      threads_sem request 
 218      while addressof:first_zombie<>null 
 219        var Pointer:ThreadHeader :> first_zombie ; first_zombie :> next 
 220        threads_sem release 
 221        var Int pid := os_waitpid h:pid (null map Int) 80000000h # waits for a cloned process 
 222        threads_sem request 
 223        if pid=h:pid 
 224          pid := 0 
 225          next :> first_available ; first_available :> h 
 226        else 
 227          next :> lost ; lost :> h 
 228      while addressof:lost<>null 
 229        :> lost ; lost :> next 
 230        next :> first_zombie ; first_zombie :> h 
 231      threads_sem release 
 232   
 233    function allocate_stack -> h 
 234      arg_RW ThreadHeader h 
 235      threads_sem request 
 236      if addressof:first_available<>null 
 237        :> first_available ; first_available :> next 
 238        threads_sem release 
 239      else 
 240        var Address bottom := cast stack_base.-.thread_stacks_count*stack_size Address 
 241        if (cast bottom uInt)<(cast memory_base_address uInt) 
 242          error_notify_fatal error_id_memory_starvation "Out of memory pages for thread stacks" 
 243        memory_limit_address := bottom 
 244        thread_stacks_count := thread_stacks_count+1 
 245        threads_sem release 
 246        var Address got := os_mmap bottom stack_size os_PROT_READ+os_PROT_WRITE os_MAP_PRIVATE+os_MAP_ANONYMOUS+os_MAP_FIXED+os_MAP_GROWSDOWN -1 0 
 247        if got<>(cast -Address) 
 248          :> ((bottom translate Byte stack_size) translate ThreadHeader -1) map ThreadHeader 
 249          pid := 0 
 250        else 
 251          :> null map ThreadHeader 
 252   
 253    function free_stack h 
 254      arg_rw ThreadHeader h 
 255      threads_sem request 
 256      pid := 0 
 257      next :> first_available ; first_available :> h 
 258      threads_sem release 
 259   
 260    export record_zombie terminate_zombies allocate_stack free_stack 
 261   
 262  eif os_api="posix" or os_api="win32" or os_api="os2" 
 263   
 264    gvar FastSem threads_sem 
 265    gvar Pointer:ThreadHeader first_zombie :> null map ThreadHeader 
 266   
 267    function record_zombie h 
 268      arg_rw ThreadHeader h 
 269      threads_sem request 
 270      h next :> first_zombie ; first_zombie :> h 
 271      threads_sem release 
 272   
 273    function terminate_zombies 
 274      if addressof:first_zombie=null 
 275        return 
 276      threads_sem request 
 277      while addressof:first_zombie<>null 
 278        var Pointer:ThreadHeader h :> first_zombie ; first_zombie :> h next 
 279        if os_api="win32" 
 280          threads_sem release 
 281          while h:handle=(-1) 
 282            os_yield 
 283          os_CloseHandle h:handle 
 284          threads_sem request 
 285        entry_unlock addressof:h 
 286      threads_sem release 
 287   
 288   
 289 
 
 290  #  running a new thread 
 291   
 292   
 293  gvar Int current_running_threads := 1 
 294  gvar Int maximum_running_threads := 1 
 295   
 296  function execute1 a f 
 297    arg Address a ; arg Function f 
 298    indirect 
 299   
 300  if os_api="linux" 
 301    
 302    function current_thread_header -> h 
 303      arg_RW ThreadHeader h 
 304      has_side_effects 
 305      var Int esp := i386_register i386_esp 
 306      var Int stack_bottom := esp .and. .not. (cast stack_size-Int) 
 307      :> (cast stack_bottom .+. (stack_size-ThreadHeader:size) Address) map ThreadHeader 
 308   
 309    function set_first_thread_info p fh 
 310      arg Address p ; arg Int fh 
 311      var Int esp := i386_register i386_esp 
 312      stack_base := esp .and. .not. (cast stack_size-Int) 
 313      var Pointer:ThreadHeader :> current_thread_header 
 314      setup 
 315      pid := os_getpid 
 316      # 
 317      thread_stacks_count := 1 
 318      first_zombie :> null map ThreadHeader 
 319      first_available :> null map ThreadHeader 
 320      recycling_first :> null map ThreadHeader 
 321    set_first_thread_info null 0 
 322    gvar DelayedAction da1 
 323    da1 function :> the_function set_first_thread_info Address Int 
 324    pliant_restore_actions insert_before pliant_restore_actions:first addressof:da1 
 325   
 326    gcc_off 
 327   
 328      function run_thread action -> success 
 329        arg DelayedAction action ; arg CBool success 
 330        if thread_trace 
 331          console "run "+action:function:position+"[lf]" 
 332        recycling_sem request 
 333        if exists:recycling_first 
 334          var Pointer:ThreadHeader :> recycling_first 
 335          recycling_first :> next 
 336          recycling_sem release 
 337          var Pointer:ThreadHeader cth :> current_thread_header 
 338          variables_context := cth variables_context 
 339          language_index := cth language_index 
 340          if has_user_field 
 341            user := cth user 
 342          action := action 
 343          restart_thread h 
 344          return true 
 345        recycling_sem release 
 346        terminate_zombies 
 347        atomic_add current_running_threads 1 
 348        maximum_running_threads := max maximum_running_threads current_running_threads 
 349        var Pointer:ThreadHeader :> allocate_stack 
 350        if not exists:h 
 351          atomic_add current_running_threads -1 
 352          return false 
 353        setup 
 354        var Pointer:ThreadHeader cth :> current_thread_header 
 355        variables_context := cth variables_context 
 356        language_index := cth language_index 
 357        if has_user_field 
 358          user := cth user 
 359        DelayedAction build_instance (addressof h:action) 
 360        ErrorRecord build_instance (addressof h:bottom_error) 
 361        action := action 
 362        var Int pid := os_clone 8F00h (addressof:translate Byte -256) 
 363        if pid=0 
 364          :> current_thread_header 
 365          pid := os_getpid 
 366          os_sigsetmask 2^(pliant_suspend_signal-1) 
 367          thread_insert_header h 
 368          execute1 h:action:parameter h:action:function 
 369          error_report 
 370          while pliant_execution_phase<=execution_phase_run and (exists h:action:function) 
 371            DelayedAction destroy_instance (addressof h:action) 
 372            DelayedAction build_instance (addressof h:action) 
 373            ActionRecord build_instance addressof:(var ActionRecord ar) 
 374            action_push_record (var ActionRecord ar) "recycling" 
 375            recycling_sem request 
 376            next :> recycling_first 
 377            recycling_first :> h 
 378            recycling_sem release 
 379            stop_current_thread 
 380            action_pull_record ar 
 381            ActionRecord destroy_instance addressof:ar 
 382            if (exists h:action:function) 
 383              execute1 h:action:parameter h:action:function 
 384            error_report 
 385          thread_remove_header h 
 386          ErrorRecord destroy_instance (addressof h:bottom_error) 
 387          record_zombie h 
 388          atomic_add current_running_threads -1 
 389          os_exit 0 
 390        eif pid=(-1) 
 391          DelayedAction destroy_instance (addressof h:action) 
 392          free_stack h 
 393          atomic_add current_running_threads -1 
 394          return false 
 395        else 
 396          return true 
 397   
 398    function threads_shrink 
 399      recycling_sem request 
 400      while exists:recycling_first 
 401        var Pointer:ThreadHeader :> recycling_first 
 402        recycling_first :> next 
 403        restart_thread h 
 404      recycling_sem release 
 405     
 406  eif os_api="posix" 
 407   
 408    function pthread_key_create handle destructor -> err 
 409      arg_w Int handle ; arg Address destructor ; arg Int err 
 410      external os_libpthread_filename "pthread_key_create" 
 411   
 412    function pthread_setspecific handle value -> err 
 413      arg Int handle ; arg Address value ; arg Int err 
 414      external os_libpthread_filename "pthread_setspecific" 
 415   
 416    function pthread_getspecific handle -> value 
 417      arg Int handle ; arg Address value 
 418      external os_libpthread_filename "pthread_getspecific" 
 419   
 420    function pthread_create handle attr routine arg -> err 
 421      arg_w Int handle ; arg Address attr routine arg ; arg Int err 
 422      external os_libpthread_filename "pthread_create" 
 423   
 424    gvar Int key 
 425    gvar ThreadHeader first_thread_header 
 426   
 427    function set_first_thread_info p fh 
 428      arg Address p ; arg Int fh 
 429      first_thread_header id := pthread_self 
 430      pthread_key_create key null 
 431      pthread_setspecific key addressof:first_thread_header 
 432    set_first_thread_info null 0 
 433    gvar DelayedAction da1 
 434    da1 function :> the_function set_first_thread_info Address Int 
 435    pliant_restore_actions insert_before pliant_restore_actions:first addressof:da1 
 436   
 437    function current_thread_header -> h 
 438      arg_RW ThreadHeader h 
 439      h :> pthread_getspecific:key map ThreadHeader 
 440   
 441    function thread_execute h 
 442      arg_rw ThreadHeader h 
 443      external_calling_convention 
 444      pthread_setspecific key addressof:h 
 445      h id := pthread_self 
 446      thread_insert_header h 
 447      execute1 h:action:parameter h:action:function 
 448      thread_remove_header h 
 449      error_report 
 450      h:bottom_error context := null 
 451      h:action parameter := null 
 452      record_zombie h 
 453      atomic_add current_running_threads -1 
 454   
 455    gcc_off 
 456   
 457      function run_thread action -> success 
 458        arg DelayedAction action ; arg CBool success 
 459        terminate_zombies 
 460        atomic_add current_running_threads 1 
 461        maximum_running_threads := max maximum_running_threads current_running_threads 
 462        var Pointer:ThreadHeader h :> new ThreadHeader ; entry_lock addressof:h 
 463        h setup 
 464        var Pointer:ThreadHeader cth :> current_thread_header 
 465        h variables_context := cth variables_context 
 466        h language_index := cth language_index 
 467        if has_user_field 
 468          h user := cth user 
 469        h action := action 
 470        success := (pthread_create (var Int handle) null (the_function thread_execute ThreadHeader):executable addressof:h)=0 
 471        if not success 
 472          atomic_add current_running_threads -1 
 473          entry_unlock addressof:h 
 474   
 475    function threads_shrink 
 476       void 
 477   
 478  eif os_api="win32" 
 479   
 480    gvar ThreadHeader first_thread_header 
 481   
 482    if pliant_debugging_level>=1 
 483      module "/pliant/language/debug/report.pli" 
 484   
 485    function set_first_thread_info p fh 
 486      arg Address p ; arg Int fh 
 487      os_DuplicateHandle os_GetCurrentProcess os_GetCurrentThread os_GetCurrentProcess first_thread_header:handle 0 false DUPLICATE_SAME_ACCESS 
 488      if pliant_debugging_level>=1 
 489        'first thread handle' := first_thread_header handle 
 490      tls := os_TlsAlloc 
 491      os_TlsSetValue tls addressof:first_thread_header 
 492    set_first_thread_info null 0 
 493    gvar DelayedAction da1 
 494    da1 function :> the_function set_first_thread_info Address Int 
 495    pliant_restore_actions insert_before pliant_restore_actions:first addressof:da1 
 496   
 497    function thread_execute h 
 498      arg_rw ThreadHeader h 
 499      external_calling_convention 
 500      os_TlsSetValue tls addressof:h 
 501      thread_insert_header h 
 502      execute1 h:action:parameter h:action:function 
 503      thread_remove_header h 
 504      error_report 
 505      h:bottom_error context := null 
 506      h:action parameter := null 
 507      record_zombie h 
 508      atomic_add current_running_threads -1 
 509   
 510    function run_thread action -> success 
 511      arg DelayedAction action ; arg CBool success 
 512      terminate_zombies 
 513      atomic_add current_running_threads 1 
 514      maximum_running_threads := max maximum_running_threads current_running_threads 
 515      var Pointer:ThreadHeader h :> new ThreadHeader ; entry_lock addressof:h 
 516      h setup 
 517      var Pointer:ThreadHeader cth :> current_thread_header 
 518      h variables_context := cth variables_context 
 519      h language_index := cth language_index 
 520      if has_user_field 
 521        h user := cth user 
 522      h action := action 
 523      h handle := -1 
 524      h handle := os_CreateThread null 0 (the_function thread_execute ThreadHeader):executable addressof:h 0 (var Int tid) 
 525      success := h:handle<>0 
 526      if not success 
 527        atomic_add current_running_threads -1 
 528        entry_unlock addressof:h 
 529   
 530    function threads_shrink 
 531       void 
 532   
 533  eif os_api="os2" 
 534   
 535    public 
 536      gvar Int stack_size := 1024*2^10 
 537    gvar ThreadHeader first_thread_header 
 538    gvar Address thread_mem 
 539   
 540    function set_first_thread_info p fh 
 541      arg Address p ; arg Int fh 
 542      os_DosGetInfoBlocks (var Pointer:os_TIB tib) (var Pointer:os_PIB pib) 
 543      first_thread_header tid := tib:tib2:tid 
 544      os_DosAllocThreadLocalMemory 1 thread_mem 
 545      thread_mem map Address := addressof first_thread_header 
 546    set_first_thread_info null 0 
 547    gvar DelayedAction da1 
 548    da1 function :> the_function set_first_thread_info Address Int 
 549    pliant_restore_actions insert_before pliant_restore_actions:first addressof:da1 
 550   
 551    function current_thread_header -> h 
 552      arg_RW ThreadHeader h 
 553      h :> thread_mem map Pointer:ThreadHeader 
 554   
 555    if pliant_debugging_level>=1 
 556      module "/pliant/language/debug/report.pli" 
 557   
 558    function thread_execute h 
 559      arg_rw ThreadHeader h 
 560      external_calling_convention 
 561      if pliant_debugging_level>=1 
 562        var os_ExceptionHandler eh 
 563        eh previous := null 
 564        eh executable := (the_function 'os2 exception routine' os_ExceptionReport os_ExceptionHandler os_ExceptionContext Address -> Int) executable 
 565        os_DosSetExceptionHandler eh 
 566      os_DosGetInfoBlocks (var Pointer:os_TIB tib) (var Pointer:os_PIB pib) 
 567      h tid := tib:tib2:tid 
 568      thread_mem map Address := addressof h 
 569      thread_insert_header h 
 570      execute1 h:action:parameter h:action:function 
 571      thread_remove_header h 
 572      error_report 
 573      h:bottom_error context := null 
 574      h:action parameter := null 
 575      record_zombie h 
 576      atomic_add current_running_threads -1 
 577      if pliant_debugging_level>=1 
 578        os_DosUnsetExceptionHandler eh 
 579   
 580    function run_thread action -> success 
 581      arg DelayedAction action ; arg CBool success 
 582      terminate_zombies 
 583      atomic_add current_running_threads 1 
 584      maximum_running_threads := max maximum_running_threads current_running_threads 
 585      var Pointer:ThreadHeader h :> new ThreadHeader ; entry_lock addressof:h 
 586      h setup 
 587      var Pointer:ThreadHeader cth :> current_thread_header 
 588      h variables_context := cth variables_context 
 589      h language_index := cth language_index 
 590      if has_user_field 
 591        h user := cth user 
 592      h action := action 
 593      success := (os_DosCreateThread (var Int tid) (the_function thread_execute ThreadHeader):executable addressof:h 0 stack_size)=0 
 594      if not success 
 595        atomic_add current_running_threads -1 
 596        entry_unlock addressof:h 
 597   
 598    function threads_shrink 
 599       void 
 600   
 601  if os_api="posix" or os_api="win32" or os_api="os2" 
 602    if addressof:current_thread_header<>addressof:first_thread_header 
 603      error error_id_os "Threads interface seems to be buggy under "+os_api # +" "+'convert to string':(cast addressof:current_thread_header Int)+" "+'convert to string':(cast addressof:first_thread_header Int) 
 604   
 605   
 606  export run_thread threads_shrink current_thread_header 
 607  export current_running_threads maximum_running_threads 
 608   
 609   
 610  if os_api="linux" 
 611   
 612    public 
 613      gvar Address memory_semaphore_address 
 614   
 615    if pliant_c_debugging_level>=2 
 616      function nolock 
 617        void 
 618      entry_root addressof:(the_function nolock) 
 619   
 620    function back_to_single_thread 
 621      var Int me := os_getpid 
 622      for (var Int i) thread_stacks_count-1 0 step -1 
 623        var Int bottom := stack_base.-.i*stack_size 
 624        var Pointer:ThreadHeader :> (cast bottom .+. (stack_size-ThreadHeader:size) Address) map ThreadHeader 
 625        if h:pid<>me and h:pid>0 
 626          os_kill h:pid os_SIGKILL 
 627      memory_semaphore_address map Int := 0 
 628      if pliant_c_debugging_level>=2 
 629        pliant_entry_lock_hook := the_function:nolock executable ; pliant_entry_unlock_hook := the_function:nolock executable 
 630   
 631    export back_to_single_thread 
 632   
 633    if pliant_debugging_level=0 
 634   
 635      gvar CBool first_time := true 
 636   
 637      function error_fatal_hook id message 
 638        arg Int id ; arg Str message 
 639        console message ; console "[lf]" 
 640        if first_time 
 641          first_time := false 
 642          back_to_single_thread 
 643        os_exit (min id (addressof:error_id_user map Int)) 
 644   
 645      entry_root addressof:(the_function error_fatal_hook Int Str) 
 646      pliant_error_fatal_hook := (the_function error_fatal_hook Int Str) executable 
 647   
 648      function exception_handler2 num mark1 mark2 mark3 mark4 edi esi ebp esp ebx edx ecx eax drop1 drop2 eip 
 649        arg Int num mark1 mark2 mark3 mark4 edi esi ebp esp ebx edx ecx eax drop1 drop2 eip 
 650        external_calling_convention 
 651        if first_time 
 652          first_time := false 
 653          back_to_single_thread 
 654          console "exception " ; console 'convert to string':num ; console "[lf]" 
 655        os_exit 4 
 656   
 657      gvar os_sigaction sa 
 658      sa sa_handler := (the_function exception_handler2 Int Int Int Int Int Int Int Int Int Int Int Int Int Int Int Int) executable 
 659      entry_root addressof:(the_function exception_handler2 Int Int Int Int Int Int Int Int Int Int Int Int Int Int Int Int) 
 660   
 661      function record_exception_handler parameter filehandle 
 662        arg Address parameter ; arg Int filehandle 
 663        # catching bugs 
 664        if (os_sigaction os_SIGSEGV sa (null map os_sigaction))<>0 
 665          error error_id_os "Failed to install Linux SIGSEGV exception handler" 
 666        if (os_sigaction os_SIGBUS sa (null map os_sigaction))<>0 
 667          error error_id_os "Failed to install Linux SIGBUS exception handler" 
 668        if (os_sigaction os_SIGFPE sa (null map os_sigaction))<>0 
 669          error error_id_os "Failed to install Linux SIGFPE exception handler" 
 670        # catching terminal close 
 671        if (os_sigaction os_SIGHUP sa (null map os_sigaction))<>0 
 672          error error_id_os "Failed to install Linux SIGHUP exception handler" 
 673        # catching Ctrl+C 
 674        if (os_sigaction os_SIGINT sa (null map os_sigaction))<>0 
 675          error error_id_os "Failed to install Linux SIGINT exception handler" 
 676        # catching kill 
 677        if (os_sigaction os_SIGTERM sa (null map os_sigaction))<>0 
 678          error error_id_os "Failed to install Linux SIGTERM exception handler" 
 679      record_exception_handler null 0 
 680      gvar DelayedAction da 
 681      da function :> the_function record_exception_handler Address Int 
 682      pliant_restore_actions append addressof:da 
 683   
 684   
 685 
 
 686  #  multithreaded errors handling 
 687   
 688   
 689  function mt_action_push_record ar action 
 690    arg_w ActionRecord ar ; arg Str action 
 691    if (addressof ar:next)<>(cast -Address) 
 692      error_notify_fatal error_id_unexpected "Action record pushed twice" 
 693    if pliant_verbose_level_variable>=2 
 694      console "[cr]"+(action 0 78)+" " 
 695    ar action := action 
 696    var Pointer:ThreadHeader :> current_thread_header 
 697    h:action_sem request  
 698    ar next :> top_action 
 699    top_action :> ar 
 700    h:action_sem release 
 701   
 702  function mt_action_pull_record ar 
 703    arg_rw ActionRecord ar 
 704    if (addressof ar:next)<>(cast -Address) 
 705      var Pointer:ThreadHeader :> current_thread_header 
 706      while true 
 707        h:action_sem request  
 708        var Pointer:ActionRecord top :> top_action 
 709        if not exists:top 
 710          error_notify_fatal error_id_unexpected "Wrong action record pulled ("+ar:action+")" 
 711        top_action :> top next 
 712        h:action_sem release 
 713        top next :> (cast -Address) map ActionRecord 
 714        if addressof:top=addressof:ar 
 715          return 
 716   
 717  function mt_action_top_record -> a 
 718    arg_RW ActionRecord a 
 719    :> current_thread_header top_action 
 720   
 721   
 722  function mt_error_push_record e filter 
 723    arg_w ErrorRecord e ; arg ErrorID filter 
 724    if (addressof e:next)<>(cast -Address) 
 725      error_notify_fatal error_id_unexpected "Error record pushed twice" 
 726    id := error_id_noerror 
 727    filter := filter 
 728    var Pointer:ThreadHeader :> current_thread_header 
 729    next :> top_error 
 730    top_error :> e 
 731   
 732  function mt_error_pull_record e 
 733    arg_rw ErrorRecord e 
 734    var Pointer:ThreadHeader :> current_thread_header 
 735    if (addressof h:top_error)<>addressof:e 
 736      error_notify_fatal error_id_corrupted "Wrong error record pulled" 
 737    error_propagate e:next 
 738    top_error :> next 
 739    error_report 
 740    next :> (cast -Address) map ErrorRecord 
 741   
 742  function mt_error_top_record -> e 
 743    arg_RW ErrorRecord e 
 744    :> current_thread_header top_error 
 745   
 746  export mt_action_push_record mt_action_pull_record 
 747   
 748   
 749  entry_root addressof:(the_function mt_action_push_record ActionRecord Str) 
 750  entry_root addressof:(the_function mt_action_pull_record ActionRecord) 
 751  entry_root addressof:(the_function mt_action_top_record -> ActionRecord) 
 752  entry_root addressof:(the_function mt_error_push_record ErrorRecord ErrorID) 
 753  entry_root addressof:(the_function mt_error_pull_record ErrorRecord) 
 754  entry_root addressof:(the_function mt_error_top_record -> ErrorRecord) 
 755  function activate_mt_hooks 
 756    var Pointer:ThreadHeader :> current_thread_header 
 757    top_action :> action_top_record 
 758    top_error :> error_top_record 
 759    pliant_action_push_record_hook := (the_function mt_action_push_record ActionRecord Str) executable 
 760    pliant_action_pull_record_hook := (the_function mt_action_pull_record ActionRecord) executable 
 761    pliant_action_top_record_hook := (the_function mt_action_top_record -> ActionRecord) executable 
 762    pliant_error_push_record_hook := (the_function mt_error_push_record ErrorRecord ErrorID) executable 
 763    pliant_error_pull_record_hook := (the_function mt_error_pull_record ErrorRecord) executable 
 764    pliant_error_top_record_hook := (the_function mt_error_top_record -> ErrorRecord) executable 
 765  activate_mt_hooks 
 766   
 767  function restore_mt_hooks p fh 
 768    arg Address p ; arg Int fh 
 769    var Pointer:ThreadHeader :> current_thread_header 
 770    current_running_threads := 1 
 771    thread_list_pivot list_next :> thread_list_pivot ; thread_list_pivot list_previous :> thread_list_pivot 
 772    thread_insert_header h 
 773  gvar DelayedAction restore 
 774  restore function :> the_function restore_mt_hooks Address Int 
 775  pliant_restore_actions insert_after pliant_restore_actions:first addressof:restore 
 776   
 777  function do_nothing drop 
 778    arg Address drop 
 779   
 780  function shutdown_threads p 
 781    arg Address p 
 782    if os_api="linux" 
 783      while { recycling_sem request ; exists recycling_first } 
 784        var Pointer:ThreadHeader :> recycling_first 
 785        recycling_first :> next 
 786        recycling_sem release 
 787        h:action function :> the_function do_nothing Address 
 788        restart_thread h 
 789        os_yield 
 790      recycling_sem release 
 791    terminate_zombies 
 792  gvar DelayedAction shutdown 
 793  shutdown function :> the_function shutdown_threads Address 
 794  pliant_shutdown_actions append addressof:shutdown 
 795   
 796   
 797 
 
 798  #  handling waiting threads queues 
 799   
 800   
 801  type ThreadQueue 
 802    field Pointer:ThreadHeader first 
 803   
 804  function build  q 
 805    arg_w ThreadQueue q 
 806    first :> null map ThreadHeader 
 807   
 808  method q is_empty -> empty 
 809    arg ThreadQueue q ; arg CBool empty 
 810    empty := (addressof q:first)=null 
 811   
 812   
 813  method queue add_current_thread priority restart_cost 
 814    arg_rw ThreadQueue queue ; arg Int priority ; arg Int restart_cost 
 815    var (Pointer Pointer:ThreadHeader) :>> queue first 
 816    while addressof:q<>null and q:priority>=priority 
 817      :>> next 
 818    var Pointer:ThreadHeader :> current_thread_header 
 819    priority := priority 
 820    restart_cost := restart_cost 
 821    next :> q ; :> h 
 822   
 823  method queue restart_some_threads quantity 
 824    arg_rw ThreadQueue queue ; arg Int quantity 
 825    var Pointer:ThreadHeader :> queue first 
 826    if addressof:h<>null 
 827      var Int := restart_cost 
 828      var Pointer:ThreadHeader stop :> next 
 829      restart_thread h 
 830      while addressof:stop<>null and q+stop:restart_cost<=quantity 
 831        :> stop 
 832        += restart_cost 
 833        stop :> next 
 834        restart_thread h 
 835      queue first :> stop 
 836   
 837  if true 
 838    method queue restart_some_threads quantity variable value 
 839      arg_rw ThreadQueue queue ; arg Int quantity ; arg_rw uInt variable ; arg uInt value 
 840      if true 
 841        var Pointer:ThreadHeader start :> queue first 
 842        if addressof:start<>null 
 843          var Int := start restart_cost 
 844          var Pointer:ThreadHeader stop :> start next 
 845          while addressof:stop<>null and q+stop:restart_cost<=quantity 
 846            += stop restart_cost 
 847            stop :> stop next 
 848          queue first :> stop 
 849          variable := value 
 850          while addressof:start<>addressof:stop 
 851            var Pointer:ThreadHeader :> start 
 852            start :> next 
 853            restart_thread h 
 854        else 
 855          variable := value 
 856      else 
 857        queue restart_some_threads quantity 
 858        variable := value 
 859   
 860   
 861  export stop_current_thread restart_thread 
 862  export ThreadQueue '. is_empty' '. add_current_thread' '. restart_some_threads' 
 863   
 864