Patch title: Release 90 bulk changes
Abstract:
File: /language/debug/profiler.pli
Key:
    Removed line
    Added line
module "/pliant/language/compiler.pli"
module "/pliant/language/misc/hooks.pli"
module "/pliant/language/debug/record.pli"
module "/pliant/language/os.pli"
module "/pliant/language/stream.pli"

constant custom_locking true


if custom_locking
  constant not_locked 0
  constant write_locked 80000000h
  constant please_retry 0FFFFFFFFh
  gvar uInt sem := not_locked
else
  gvar Sem sem

function profiler_sem_request
  if custom_locking
    while { var uInt s := atomic_read_and_set sem please_retry ; s<>not_locked }
      if s<>please_retry
        sem := s
      os_yield
    sem := write_locked
  else
    sem request
entry_root addressof:(the_function profiler_sem_request)
  
function profiler_sem_release
  if custom_locking
    while (var uInt s := atomic_read_and_set sem please_retry ; s=please_retry)
      os_yield
    sem := not_locked
  else
    sem release
entry_root addressof:(the_function profiler_sem_release)
  
if true # do not remove the 'if true' since both instructions must be executed in the same compile/execute round trip
  pliant_function_lock_hook := (the_function profiler_sem_request) executable
  pliant_function_unlock_hook := (the_function profiler_sem_release) executable


#---------------------------------------------------------------------------


type os_itimerval
  field os_timeval it_interval
  field os_timeval it_value

constant os_ITIMER_REAL 0
constant os_ITIMER_PROF 2

constant os_SIGALRM 14
constant os_SIGPROF 27

function os_setitimer which value old_value -> err
  arg Int which ; arg_rw os_itimerval value ; arg_w os_itimerval old_value ; arg Int err
  kernel_function 104


#---------------------------------------------------------------------------


gvar Int nowhere := 0
gvar CBool profiler_recurse := false
gvar Int profiler_recurse := 0


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

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 profiler_record initial_eip initial_ebp
  arg Address initial_eip initial_ebp
  var Address eip := initial_eip
  var Address ebp := initial_ebp
  var Address mini := ebp
  var Int level := 0
  while (cast ebp uInt)>=(cast mini uInt) and ebp<>null
    var Link:Function f :> search_function_at eip
    if exists:f and f:executable_size<>0
      atomic_increment f:profiler_counter
      var Pointer:DebuggerInstructionRecord best :> null map DebuggerInstructionRecord
      find_instruction f:externals f eip best
      if exists:best
        atomic_increment best:profiler_counter
    if not profiler_recurse
    if level>=profiler_recurse
      if not exists:f
        atomic_increment nowhere
      return
    mini := ebp translate Byte 1
    eip := (ebp translate Int 1) map Address
    ebp := ebp map Address
    level += 1

function profiler_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 custom_locking
    while { var uInt s := atomic_read_and_set sem please_retry ; s=please_retry }
      os_yield
    if s<>write_locked
      sem := s+1
      profiler_record (cast eip.-.1 Address) (cast ebp Address)
      while { var uInt s := atomic_read_and_set sem please_retry ; s=please_retry }
        os_yield
      sem := s-1
    else
      sem := s
  else
    if sem:nowait_rd_request
      profiler_record (cast eip.-.1 Address) (cast ebp Address)
      sem rd_release

gvar os_sigaction sa
sa sa_handler := (the_function profiler_handler Int Int Int Int Int Int Int Int Int Int Int Int Int Int Int Int) executable
entry_root addressof:(the_function profiler_handler Int Int Int Int Int Int Int Int Int Int Int Int Int Int Int Int)

function record_profiler_handler parameter filehandle
  arg Address parameter ; arg Int filehandle
  # if (os_sigaction os_SIGALRM sa (null map os_sigaction))<>0
  #   error error_id_os "Failed to install Linux SIGALRM exception handler"
  if (os_sigaction os_SIGPROF sa (null map os_sigaction))<>0
    error error_id_os "Failed to install Linux SIGPROF exception handler"
record_profiler_handler null 0
gvar DelayedAction da
da function :> the_function record_profiler_handler Address Int
pliant_restore_actions append addressof:da


#---------------------------------------------------------------------------


function profiler_start resolution
  arg Float resolution
  var os_itimerval t
  t:it_interval tv_sec := 0
  t:it_interval tv_usec := cast resolution*10^6 Int
  t:it_value tv_sec := t:it_interval tv_sec
  t:it_value tv_usec :=  t:it_interval tv_usec
  # if (os_setitimer os_ITIMER_REAL t (null map os_itimerval))<>0
  #   console "failed to start profiler" eol
  if (os_setitimer os_ITIMER_PROF t (null map os_itimerval))<>0
    console "failed to start profiler" eol

function profiler_start
  profiler_start 0.1


function profiler_stop
  memory_clear addressof:(var os_itimerval t) os_itimerval:size
  # if (os_setitimer os_ITIMER_REAL t (null map os_itimerval))<>0
  #   console "failed to stop profiler" eol
  if (os_setitimer os_ITIMER_PROF t (null map os_itimerval))<>0
    console "failed to stop profiler" eol


function enumerate_instructions a sort
  arg Address a ; arg_rw (Index Int Address) sort
  if a=null
    return
  var Pointer:Type t :> entry_type a
  if t=DebuggerInstructionRecord
    var Pointer:DebuggerInstructionRecord fi :> a map DebuggerInstructionRecord
    if fi:profiler_counter<>0
      sort insert fi:profiler_counter addressof: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 fi:profiler_counter<>0
        sort insert fi:profiler_counter addressof:fi
  eif t=List
    var Pointer:Arrow item :> (a map List) first
    while item<>null
      enumerate_instructions item sort
      item :> (a map List) next item
  eif t=Array
    for (var Int i) 0 (a map Array):size-1
      enumerate_instructions (a map Array):i sort

function profiler_report name position stream
  arg Str name position ; arg_rw Stream stream
  if custom_locking
    while { var uInt s := atomic_read_and_set sem please_retry ; s=please_retry or s=write_locked }
      if s<>please_retry
        sem := s
      os_yield
    sem := s+1
  else
    sem rd_request
  if name="" and position=""
    var (Index Int Address) sort
    var Pointer:Function f :> pliant_first_function
    while addressof:f<>null
      if f:profiler_counter<>0
        sort insert f:profiler_counter addressof:f
      f :> f next_function
    if nowhere<>0
      stream writeline "[dq][dq] [dq]unknown[dq] "+string:nowhere
    each a sort reversed
      var Pointer:Function f :> a map Function
      stream writeline (string f:name)+" "+string:(cast f:position Str)+" "+string:(sort key a)
  else
    var Pointer:Function f :> pliant_first_function
    while addressof:f<>null
      if f:name=name and f:position=position
        var (Index Int Address) sort
        enumerate_instructions f:externals sort
      f :> f next_function
    each a sort reversed
      var Pointer:DebuggerInstructionRecord i :> a map DebuggerInstructionRecord
      stream writeline string:(cast i:position Str)+" "+string:(sort key a)
  if custom_locking
    while { var uInt s := atomic_read_and_set sem please_retry ; s=please_retry }
      os_yield
    sem := s-1
  else
    sem rd_release


function reset_instructions a
  arg Address a
  if a=null
    return
  var Pointer:Type t :> entry_type a
  if t=DebuggerInstructionRecord
    var Pointer:DebuggerInstructionRecord fi :> a map DebuggerInstructionRecord
    fi profiler_counter := 0
  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
      fi profiler_counter := 0
  eif t=List
    var Pointer:Arrow item :> (a map List) first
    while item<>null
      reset_instructions item
      item :> (a map List) next item
  eif t=Array
    for (var Int i) 0 (a map Array):size-1
      reset_instructions (a map Array):i

function profiler_reset
  if custom_locking
    profiler_sem_request
  else
    sem request
  nowhere := 0  
  var Pointer:Function f :> pliant_first_function
  while addressof:f<>null
    f profiler_counter := 0
    reset_instructions f:externals
    f :> f next_function
  if custom_locking
    profiler_sem_release
  else
    sem release

export profiler_recurse profiler_start profiler_stop
export profiler_report profiler_reset