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

module "/pliant/install/ring2.pli"

constant execute pliant_debugging_level>0
constant debug false


#-----------------------------------------------------------------------
# slot


gvar List trace_slots ; gvar FastSem trace_slots_sem
gvar CBool trace_memory := false


type TraceSlot
  if execute
    field CBool is_active <- false
    field List handlers
    field Sem sem
  field Str name


method ts reset
  arg_rw TraceSlot ts
  if execute
    trace_slots_sem request
    var Pointer:Arrow c :> trace_slots first
    while c<>null
      if c=addressof:ts
        trace_slots remove c
        return
      c :> trace_slots next c
    trace_slots_sem release

if execute
  function destroy ts
    arg_w TraceSlot ts
    if pliant_execution_phase>execution_phase_free
      return
    ts reset

     
method ts configure name
  arg_rw TraceSlot ts ; arg Str name
  if execute
    ts reset
    ts name := name
    trace_slots_sem request
    trace_slots append addressof:ts
    trace_slots_sem release


#-----------------------------------------------------------------------
# handler


type TraceHandler
  void

method h line message
  arg_rw TraceHandler h ; arg Str message
  generic

method h flush
  arg_rw TraceHandler h
  generic


method h bind slot
  arg_rw TraceHandler h ; arg_rw TraceSlot slot
  if execute
    slot:sem request
    slot:handlers append addressof:h
    slot is_active := true
    slot:sem release

method h unbind slot
  arg_rw TraceHandler h ; arg_rw TraceSlot slot
  if execute
    slot:sem request
    var Pointer:Arrow c :> slot:handlers first
    while c<>null
      if c=addressof:h
        slot:handlers remove c
        if slot:handlers:first=null
          slot:is_active := false
        slot:sem release
        return
      c :> slot:handlers next c
    slot:sem release


if execute
  method slot line message
    arg_rw TraceSlot slot ; arg Str message
    slot:sem request
    if debug
      console "trace "+message+"[lf]"
    var Pointer:Arrow c :> slot:handlers first
    while c<>null
      (c omap TraceHandler) line message
      (c omap TraceHandler) flush
      c :> slot:handlers next c
    slot:sem release


#-----------------------------------------------------------------------
# session


type TraceSession
  if execute
    field CBool is_active <- false
    field List:Str lines
    field Pointer:TraceSlot slot
    field Int used consumed

if execute
  function create s
    arg_w TraceSession s
    s slot :> null map TraceSlot

method s bind slot
  arg_rw TraceSession s ; arg_rw TraceSlot slot
  if execute
    s slot :> slot
    s is_active := slot is_active
    s used := memory_current_used
    s consumed := memory_current_consumed

if execute
  method s line message
    arg_rw TraceSession s ; arg Str message
    # this method is not thread safe: have one log session per thread
    s lines += message
  
method s flush
  arg_rw TraceSession s
  if execute
    if not (exists s:lines:first)
      return
    var Pointer:TraceSlot slot :> s slot
    slot:sem request
    if debug
      var Pointer:Str l :> s:lines first
      while exists:l
        console "trace "+l+"[lf]"
        l :> s:lines next l
    var Pointer:Arrow c :> slot:handlers first
    while c<>null
      if trace_memory
        (c omap TraceHandler) line "old memory usage: "+(string s:used)+"/"+(string s:consumed)+" ("+(string s:consumed\2^20)+" MB)"
      var Pointer:Str l :> s:lines first
      while exists:l
        (c omap TraceHandler) line l
        l :> s:lines next l
      if trace_memory
        var Int used := memory_current_used
        var Int consumed := memory_current_consumed
        (c omap TraceHandler) line "new memory usage: "+string:used+"/"+string:consumed+" ("+(string consumed\2^20)+" MB)"
      (c omap TraceHandler) flush
      c :> slot:handlers next c
    slot:sem release
    s lines := var List:Str empty_list

if execute
  function destroy s
    arg_w TraceSession s
    s flush


method s mark -> m
  arg TraceSession s ; arg Address m
  if execute
    m := addressof s:lines:last

method s rewind m
  arg_rw TraceSession s ; arg Address m
  if execute
    while (addressof s:lines:last)<>m
      s:lines remove s:lines:last


#-----------------------------------------------------------------------
# application interface


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

if execute
  
  function to_string data options function -> string
    arg Universal data ; arg Str options ; arg Function function ; arg Str string
    indirect
  
  function trace_single u f slot
    arg Universal u ; arg Function f ; arg_rw TraceSlot slot
    slot line (to_string u "raw" f)
  
  function trace_single u f session
    arg Universal u ; arg Function f ; arg_rw TraceSession session
    session line (to_string u "raw" f)
  
  function trace_first u f s
    arg Universal u ; arg Function f ; arg_w Str s
    s := to_string u "raw" f
  
  function trace_next u f s
    arg Universal u ; arg Function f ; arg_rw Str s
    s += to_string u "raw" f
  
  function trace_last u f s slot
    arg Universal u ; arg Function f ; arg Str s ; arg_rw TraceSlot slot
    slot line s+(to_string u "raw" f)

  function trace_last u f s session
    arg Universal u ; arg Function f ; arg Str s ; arg_rw TraceSession session
    session line s+(to_string u "raw" f)


meta '. trace' e
  var Link:Argument slot session
  if e:size<2
    return
  eif (e:0 cast TraceSlot)
    slot :> e:0 result
    session :> null map Argument
  eif (e:0 cast TraceSession)
    slot :> null map Argument
    session :> e:0 result
  else
    return
  if (e:0:access .and. access_write)=0
    return
  if execute
    var Link:Argument cond :> argument indirect CBool (argument local Address) 0
    e suckup e:0
    if exists:slot
      e add (instruction (the_function '. is_active' TraceSlot -> CBool) e:0:result cond)
    else
      e add (instruction (the_function '. is_active' TraceSession -> CBool) e:0:result cond)
    var Link:Instruction end :> instruction the_function:'do nothing'
    e add (instruction (the_function 'jump if not' CBool) cond jump end)
  var Int base := 1
  for (var Int i) base e:size-1
    e:i compile ?
    var Pointer:Type type :> e:i:result:type:real_data_type
    e:i cast type ?
    var Pointer:Function function :> type get_generic_method to_index
    if addressof:function=null or addressof:function=addressof:(the_function '. to string' Universal Str -> Str)
      return
    if execute
      e suckup e:i
      if e:size-base=1
        if exists:slot
          e add (instruction (the_function trace_single Universal Function TraceSlot) e:i:result (argument mapped_constant Function function) slot)
        else
          e add (instruction (the_function trace_single Universal Function TraceSession) e:i:result (argument mapped_constant Function function) session)
      eif i=base
        var Link:Argument buf :> argument local Str
        e add (instruction (the_function trace_first Universal Function Str) e:i:result (argument mapped_constant Function function) buf)
      eif i=e:size-1
        if exists:slot
          e add (instruction (the_function trace_last Universal Function Str TraceSlot) e:i:result (argument mapped_constant Function function) buf slot)
        else
          e add (instruction (the_function trace_last Universal Function Str TraceSession) e:i:result (argument mapped_constant Function function) buf session)
      else
        e add (instruction (the_function trace_next Universal Function Str) e:i:result (argument mapped_constant Function function) buf)
  if execute
    e add end
  e set_void_result


export trace_slots trace_slots_sem trace_memory
export TraceSlot '. configure' '. reset' '. name'
export TraceHandler '. bind' '. unbind' '. line' '. flush'
export TraceSession '. bind' '. flush' '. mark' '. rewind'
export '. trace'