Patch title: Release 94 bulk changes
Abstract:
File: /pliant/language/debug/report.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"

constant maximum_variable_length 200
gvar CBool first_time := true


function search_function_at eip -> fun
  arg Address eip ; arg_R Function fun
  fun :> null map Function
  var Pointer:Function f :> pliant_first_function
  while addressof:f<>null
    if f:executable<eip and (addressof:fun=null or f:executable>fun:executable)
      fun :> f
    f :> f next_function
  if addressof:fun<>null and fun:executable_size<>0 and (fun:executable translate Byte fun:executable_size)<eip
    fun :> null map Function


constant to_index (the_function '. to string' Universal Str -> Str):generic_index

method data to_string_ options function -> string
  arg Universal data ; arg Str options ; arg Function function ; arg Str string
  indirect

function show_value a t
  arg Address a ; arg Type t
  var Pointer:Function f :> t get_generic_method to_index
  if addressof:f<>null and addressof:f<>addressof:(the_function '. to string' Universal Str -> Str)
    var Str s := (a map Universal) to_string_ "debugger" f
    console " "
    if s:len<=maximum_variable_length
      console s
    else
      console (s 0 maximum_variable_length-4)+" ..."


function find_instruction a f eip best
  arg Address a ; arg Function f ; arg Address eip ; arg_rw Pointer:DebuggerInstructionRecord best
  if a=null
    return
  var Pointer:Type t :> entry_type a
  if t=DebuggerInstructionRecord
    var Pointer:DebuggerInstructionRecord fi :> a map DebuggerInstructionRecord
    if (f:executable translate Byte fi:code_offset)<eip and (addressof:best=null or fi:code_offset>best:code_offset)
      best :> fi
  eif t=DebuggerInstructionRecords
    var Pointer:DebuggerInstructionRecords rs :> a map DebuggerInstructionRecords
    for (var Int i) 0 rs:count-1
      var Pointer:DebuggerInstructionRecord fi :> ((addressof:rs translate Int 1) translate DebuggerInstructionRecord i) map DebuggerInstructionRecord
      if (f:executable translate Byte fi:code_offset)<eip and (addressof:best=null or fi:code_offset>best:code_offset)
        best :> fi
  eif t=List
    var Pointer:Arrow item :> (a map List) first
    while item<>null
      find_instruction item f eip best
      item :> (a map List) next item
  eif t=Array
    for (var Int i) 0 (a map Array):size-1
      find_instruction (a map Array):i f eip best

function find_variables a ebp
  arg Address a ; arg Address ebp
  if a=null
    return
  var Pointer:Type t :> entry_type a
  if t=DebuggerVariableRecord
    var Pointer:DebuggerVariableRecord fv :> a map DebuggerVariableRecord
    var Address adr := (ebp translate Int 1) translate Byte fv:stack_offset
    console "  "+fv:name+" "+fv:type:name
    show_value adr fv:type
    console "[lf]"
  eif t=List
    var Pointer:Arrow item :> (a map List) first
    while item<>null
      find_variables item ebp
      item :> (a map List) next item
  eif t=Array
    for (var Int i) 0 (a map Array):size-1
      find_variables (a map Array):i ebp

function show_details_about eip ebp -> f
  arg Address eip ebp ; arg_R Function f
  f :> search_function_at eip
  if addressof:f=null or f:executable_size=0 and (f:executable translate Byte 4096)<eip
    console "??? at " ; console 'convert to string':(cast eip Int) ; console "[lf]"
  eif f:executable_size=0
    console f:name
    if f:nb_args<>0
      console " ("
      for (var Int i) 0 f:nb_args-1
        if i<>0 console:" "
        console (f arg i):type:name
      console ")"
    console " +" ; console ('convert to string' (cast eip Int) .-. (cast f:executable Int)) ; console "[lf]"
    if addressof:f=addressof:(the_function '. compile' Expression) or addressof:f=addressof:(the_function '. execute' Expression)
      var Pointer:Expression e :> (ebp translate Int 2) map Pointer:Expression
      console "  " ; console e:position ; console "[lf]"
  else
    console f:name ; console "  " ; console f:position
    var Pointer:DebuggerInstructionRecord best :> null map DebuggerInstructionRecord
    find_instruction f:externals f eip best
    if addressof:best<>null
      console " " ; console best:position
    console "[lf]"
    find_variables f:externals ebp


function debugger_walk_stack initial_eip initial_ebp
  arg Address initial_eip initial_ebp
  if pliant_verbose_level_variable>=1 and exists:action_top_record and pliant_execution_phase=execution_phase_run
    console "----------------------------------------------------------------[lf]"
    console "actions stack is:[lf]"
    var Pointer:ActionRecord a :> action_top_record
    while exists:a
      console a:action ; console "[lf]"
      a :> a next
  if pliant_verbose_level_variable>=2 and exists:error_top_record and pliant_execution_phase=execution_phase_run
    console "----------------------------------------------------------------[lf]"
    console "errors stack is:[lf]"
    var Pointer:ErrorRecord e :> error_top_record
    while exists:e
      if e:id<>error_id_noerror
        console "error " ; console 'convert to string':((addressof e:id) map Int) ; console ":[lf]"
        console "  " ; console e:message ; console "[lf]"
      e :> e next
  if pliant_execution_phase<>execution_phase_run
    console "execution phase " ; console ('convert to string' pliant_execution_phase) ; console "[lf]"
  if true
    console "----------------------------------------------------------------[lf]"
    console "processor stack content is:[lf]"
    var Address eip := initial_eip
    var Address ebp := initial_ebp
    var Address mini := initial_ebp
    while (cast ebp uInt)>=(cast mini uInt) and ebp<>null
      var Pointer:Function f :> show_details_about eip ebp
      mini := ebp translate Byte 1
      eip := (ebp translate Int 1) map Address
      ebp := ebp map Address
  console "----------------------------------------------------------------[lf]"


function verbose_error_fatal id msg
  arg Int id ; arg Str msg
  if os_api="linux" or os_api="posix"
    console_dump "/tmp/console"
  eif os_api="win32"
    console_dump "c:/temp/console"
  if first_time
    first_time := false
    console "----------------------------------------------------------------[lf]"
    console msg ; console "[lf]"
    if os_api="linux"
      back_to_single_thread
    var Address ebp := cast i386_register:i386_ebp Address
    debugger_walk_stack ((ebp translate Int 1) map Address) (ebp map Address)
  if id<(addressof:error_id_user map Int)
    os_exit id
  else
    os_exit (addressof:error_id_user map Int)

# sets the debugging hook

entry_root addressof:(the_function verbose_error_fatal Int Str)
pliant_error_fatal_hook := (the_function verbose_error_fatal Int Str) executable


#-----------------------------------------------------------------------
# Linux exception handler

if os_api="linux"

  function exception_handler num mark1 mark2 mark3 mark4 edi esi ebp esp ebx edx ecx eax drop1 drop2 eip
    arg Int num mark1 mark2 mark3 mark4 edi esi ebp esp ebx edx ecx eax drop1 drop2 eip
    external_calling_convention
    if first_time and pliant_execution_phase<execution_phase_free
      first_time := false
      back_to_single_thread
      console_dump "/tmp/console"
      console "exception " ; console 'convert to string':num ; console "[lf]"
      debugger_walk_stack (cast eip.-.1 Address) (cast ebp Address)
    os_exit 4
  gvar os_sigaction sa
  sa sa_handler := (the_function exception_handler Int Int Int Int Int Int Int Int Int Int Int Int Int Int Int Int) executable
  entry_root addressof:(the_function exception_handler Int Int Int Int Int Int Int Int Int Int Int Int Int Int Int Int)

  function record_exception_handler parameter filehandle
    arg Address parameter ; arg Int filehandle
    # catching bugs
    if (os_sigaction os_SIGSEGV sa (null map os_sigaction))<>0
      error error_id_os "Failed to install Linux SIGSEGV exception handler"
    if (os_sigaction os_SIGBUS sa (null map os_sigaction))<>0
      error error_id_os "Failed to install Linux SIGBUS exception handler"
    if (os_sigaction os_SIGFPE sa (null map os_sigaction))<>0
      error error_id_os "Failed to install Linux SIGFPE exception handler"
    # catching terminal close
    if (os_sigaction os_SIGHUP sa (null map os_sigaction))<>0
      error error_id_os "Failed to install Linux SIGHUP exception handler"
    # catching Ctrl+C
    if (os_sigaction os_SIGINT sa (null map os_sigaction))<>0
      error error_id_os "Failed to install Linux SIGINT exception handler"
    # catching kill
    if (os_sigaction os_SIGTERM sa (null map os_sigaction))<>0
      error error_id_os "Failed to install Linux SIGTERM exception handler"
  record_exception_handler null 0
  gvar DelayedAction da
  da function :> the_function record_exception_handler Address Int
  pliant_restore_actions append addressof:da


  function check_stack
    has_side_effects
    var Int esp := i386_register i386_esp
    var Int stack_top := (esp .+. stack_size .-. 1) .and. .not. stack_size-1
    if stack_top.-.esp>stack_size*3\4
    if (esp .and. (stack_size-1))<stack_size\4
      error_notify_fatal error_id_starvation "stack overflow"

  function add_check_stack gc
    arg_rw GeneratorContext gc
    if pliant_debugging_level_variable>=2
      var Link:Instruction control :> new Instruction
      control function :> the_function check_stack
      gc insert_at_section_top section_initialize control
  alias 'pliant optimizer inline functions' add_check_stack in "/pliant/language/optimizer/basic.pli"


#-----------------------------------------------------------------------
# Posix exception handler


if os_api="posix"

  if os_kernel="OpenBSD"    # probably FreeBSD too (atleast ver >= 4.0)
    function exception_handler num info context
      arg Int num
      arg Address info
      arg os_sigcontext context
      external_calling_convention
      if first_time and pliant_execution_phase<execution_phase_free
        first_time := false
        console_dump "/tmp/console"
        console "exception " ; console 'convert to string':num ; console "[lf]"
        debugger_walk_stack (cast context:sc_pc.-.1 Address) (cast context:sc_fp Address)
      os_exit 4
    gvar os_sigaction sa
    sa sa_flags := os_SA_SIGINFO
    sa sa_sigaction := (the_function exception_handler Int Address os_sigcontext) executable
    entry_root addressof:(the_function exception_handler Int Address os_sigcontext)
  else
    function exception_handler num
      arg Int num
      external_calling_convention
      if first_time and pliant_execution_phase<execution_phase_free
        first_time := false
        console_dump "/tmp/console"
        console "exception " ; console 'convert to string':num ; console "[lf]"
        var Address ebp := cast i386_register:i386_ebp Address
        debugger_walk_stack ((ebp translate Int 1) map Address) (ebp map Address)
      os_exit 4
    gvar os_sigaction sa
    sa sa_handler := (the_function exception_handler Int) executable
    entry_root addressof:(the_function exception_handler Int)

  function record_exception_handler parameter filehandle
    arg Address parameter ; arg Int filehandle
    # catching bugs
    if (os_sigaction os_SIGSEGV sa (null map os_sigaction))<>0
      error error_id_os "Failed to install SIGSEGV exception handler"
    if (os_sigaction os_SIGBUS sa (null map os_sigaction))<>0
      error error_id_os "Failed to install SIGBUS exception handler"
    if (os_sigaction os_SIGFPE sa (null map os_sigaction))<>0
      error error_id_os "Failed to install SIGFPE exception handler"
    # catching Ctrl+C
    if (os_sigaction os_SIGINT sa (null map os_sigaction))<>0
      error error_id_os "Failed to install SIGINT exception handler"
    # catching kill
    if (os_sigaction os_SIGTERM sa (null map os_sigaction))<>0
      error error_id_os "Failed to install SIGTERM exception handler"
  record_exception_handler null 0
  gvar DelayedAction da
  da function :> the_function record_exception_handler Address Int
  pliant_restore_actions append addressof:da


#-----------------------------------------------------------------------
# Win32 exception handler


if os_api="win32"

  function exception_handler p -> ret
    arg os_EXCEPTION_POINTERS p ; arg Int ret
    external_calling_convention
    if first_time and pliant_execution_phase<execution_phase_free
      first_time := false
      console_dump "c:/temp/console"
      console "exception[lf]"
      var Pointer:os_CONTEXT c :> p ContextRecord
      debugger_walk_stack (cast c:Eip.-.1 Address) (cast c:Ebp Address)
    # os_exit 4
    ret := os_EXCEPTION_CONTINUE_SEARCH
  entry_root addressof:(the_function exception_handler os_EXCEPTION_POINTERS -> Int)

  gvar Int 'first thread handle' := -1
  export 'first thread handle'

  function break_handler signal -> ret
    arg Int signal ; arg CBool ret
    external_calling_convention
    if first_time and pliant_execution_phase<execution_phase_free
      first_time := false
      console_dump "c:/temp/console"
      console "break[lf]"
      # var Address ebp := cast i386_register:i386_ebp Address
      # debugger_walk_stack ((ebp translate Int 1) map Address) (ebp map Address)
      var os_CONTEXT c ; c ContextFlags := CONTEXT_CONTROL
      if (os_GetThreadContext 'first thread handle' c)
        debugger_walk_stack (cast c:Eip.-.1 Address) (cast c:Ebp Address)
      else
        console "no context[lf]"
    ret := false
  entry_root addressof:(the_function break_handler Int -> CBool)

  function record_exception_handler parameter filehandle
    arg Address parameter ; arg Int filehandle
    os_SetErrorMode os_SEM_FAILCRITICALERRORS+os_SEM_NOGPFAULTERRORBOX+os_SEM_SEM_NOALIGNMENTFAULTEXCEPT+os_SEM_NOOPENFILEERRORBOX
    os_SetUnhandledExceptionFilter (the_function exception_handler os_EXCEPTION_POINTERS -> Int):executable
    os_SetConsoleCtrlHandler (the_function break_handler Int -> CBool):executable true
  record_exception_handler null 0
  gvar DelayedAction da
  da function :> the_function record_exception_handler Address Int
  pliant_restore_actions append addressof:da


#-----------------------------------------------------------------------
# OS/2 exception handler


if os_api="os2"

  function 'os2 exception routine' e h c p -> ret
    arg os_ExceptionReport e
    arg os_ExceptionHandler h
    arg os_ExceptionContext c
    arg Address p
    arg Int ret
    external_calling_convention
    # exception 3 is break
    # exception 5 is memory protection fault
    if first_time and (e:num=3 or e:num=5) and pliant_execution_phase<execution_phase_free
      first_time := false
      console_dump "/tmp/console"
      console "exception " ; console ('convert to string' e:num) ; console "[lf]"
      debugger_walk_stack (cast c:eip.-.1 Address) (cast c:ebp Address)
    return 0
  entry_root addressof:(the_function 'os2 exception routine' os_ExceptionReport os_ExceptionHandler os_ExceptionContext Address -> Int)

  function record_exception_handler parameter filehandle
    arg Address parameter ; arg Int filehandle
    var Pointer:os_TIB tib ; var Pointer:os_PIB pib
    os_DosGetInfoBlocks tib pib
    var Pointer:os_ExceptionHandler eh :> (tib:stack_limit translate os_ExceptionHandler -1) map os_ExceptionHandler
    eh previous := null
    eh executable := (the_function 'os2 exception routine' os_ExceptionReport os_ExceptionHandler os_ExceptionContext Address -> Int) executable
    # os_DosError:2
    os_DosSetExceptionHandler eh
  record_exception_handler null 0
  gvar DelayedAction da
  da function :> the_function record_exception_handler Address Int
  pliant_restore_actions append addressof:da

  export 'os2 exception routine'