/pliant/language/debug/trace.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  module "/pliant/install/ring2.pli" 
 17   
 18  constant execute pliant_debugging_level>0 
 19  constant debug false 
 20   
 21   
 22 
 
 23  # slot 
 24   
 25   
 26  gvar List trace_slots ; gvar FastSem trace_slots_sem 
 27  gvar CBool trace_memory := false 
 28   
 29   
 30  type TraceSlot 
 31    if execute 
 32      field CBool is_active <- false 
 33      field List handlers 
 34      field Sem sem 
 35    field Str name 
 36   
 37   
 38  method ts reset 
 39    arg_rw TraceSlot ts 
 40    if execute 
 41      trace_slots_sem request 
 42      var Pointer:Arrow :> trace_slots first 
 43      while c<>null 
 44        if c=addressof:ts 
 45          trace_slots remove c 
 46          return 
 47        :> trace_slots next c 
 48      trace_slots_sem release 
 49   
 50  if execute 
 51    function destroy ts 
 52      arg_w TraceSlot ts 
 53      if pliant_execution_phase>execution_phase_free 
 54        return 
 55      ts reset 
 56   
 57        
 58  method ts configure name 
 59    arg_rw TraceSlot ts ; arg Str name 
 60    if execute 
 61      ts reset 
 62      ts name := name 
 63      trace_slots_sem request 
 64      trace_slots append addressof:ts 
 65      trace_slots_sem release 
 66   
 67   
 68 
 
 69  # handler 
 70   
 71   
 72  type TraceHandler 
 73    void 
 74   
 75  method h line message 
 76    arg_rw TraceHandler h ; arg Str message 
 77    generic 
 78   
 79  method h flush 
 80    arg_rw TraceHandler h 
 81    generic 
 82   
 83   
 84  method h bind slot 
 85    arg_rw TraceHandler h ; arg_rw TraceSlot slot 
 86    if execute 
 87      slot:sem request 
 88      slot:handlers append addressof:h 
 89      slot is_active := true 
 90      slot:sem release 
 91   
 92  method h unbind slot 
 93    arg_rw TraceHandler h ; arg_rw TraceSlot slot 
 94    if execute 
 95      slot:sem request 
 96      var Pointer:Arrow :> slot:handlers first 
 97      while c<>null 
 98        if c=addressof:h 
 99          slot:handlers remove c 
 100          if slot:handlers:first=null 
 101            slot:is_active := false 
 102          slot:sem release 
 103          return 
 104        :> slot:handlers next c 
 105      slot:sem release 
 106   
 107   
 108  if execute 
 109    method slot line message 
 110      arg_rw TraceSlot slot ; arg Str message 
 111      slot:sem request 
 112      if debug 
 113        console "trace "+message+"[lf]" 
 114      var Pointer:Arrow :> slot:handlers first 
 115      while c<>null 
 116        (omap TraceHandler) line message 
 117        (omap TraceHandler) flush 
 118        :> slot:handlers next c 
 119      slot:sem release 
 120   
 121   
 122 
 
 123  # session 
 124   
 125   
 126  type TraceSession 
 127    if execute 
 128      field CBool is_active <- false 
 129      field List:Str lines 
 130      field Pointer:TraceSlot slot 
 131      field Int used consumed 
 132   
 133  if execute 
 134    function create s 
 135      arg_w TraceSession s 
 136      slot :> null map TraceSlot 
 137   
 138  method s bind slot 
 139    arg_rw TraceSession s ; arg_rw TraceSlot slot 
 140    if execute 
 141      slot :> slot 
 142      is_active := slot is_active 
 143      used := memory_current_used 
 144      consumed := memory_current_consumed 
 145   
 146  if execute 
 147    method s line message 
 148      arg_rw TraceSession s ; arg Str message 
 149      # this method is not thread safe: have one log session per thread 
 150      lines += message 
 151     
 152  method s flush 
 153    arg_rw TraceSession s 
 154    if execute 
 155      if not (exists s:lines:first) 
 156        return 
 157      var Pointer:TraceSlot slot :> slot 
 158      slot:sem request 
 159      if debug 
 160        var Pointer:Str l :> s:lines first 
 161        while exists:l 
 162          console "trace "+l+"[lf]" 
 163          l :> s:lines next l 
 164      var Pointer:Arrow :> slot:handlers first 
 165      while c<>null 
 166        if trace_memory 
 167          (omap TraceHandler) line "old memory usage: "+(string s:used)+"/"+(string s:consumed)+" ("+(string s:consumed\2^20)+" MB)" 
 168        var Pointer:Str :> s:lines first 
 169        while exists:l 
 170          (omap TraceHandler) line l 
 171          :> s:lines next l 
 172        if trace_memory 
 173          var Int used := memory_current_used 
 174          var Int consumed := memory_current_consumed 
 175          (omap TraceHandler) line "new memory usage: "+string:used+"/"+string:consumed+" ("+(string consumed\2^20)+" MB)" 
 176        (omap TraceHandler) flush 
 177        :> slot:handlers next c 
 178      slot:sem release 
 179      lines := var List:Str empty_list 
 180   
 181  if execute 
 182    function destroy s 
 183      arg_w TraceSession s 
 184      flush 
 185   
 186   
 187  method s mark -> m 
 188    arg TraceSession s ; arg Address m 
 189    if execute 
 190      := addressof s:lines:last 
 191   
 192  method s rewind m 
 193    arg_rw TraceSession s ; arg Address m 
 194    if execute 
 195      while (addressof s:lines:last)<>m 
 196        s:lines remove s:lines:last 
 197   
 198   
 199 
 
 200  # application interface 
 201   
 202   
 203  constant to_index (the_function '. to string' Universal Str -> Str):generic_index 
 204   
 205  if execute 
 206     
 207    function to_string data options function -> string 
 208      arg Universal data ; arg Str options ; arg Function function ; arg Str string 
 209      indirect 
 210     
 211    function trace_single u f slot 
 212      arg Universal u ; arg Function f ; arg_rw TraceSlot slot 
 213      slot line (to_string "raw" f) 
 214     
 215    function trace_single u f session 
 216      arg Universal u ; arg Function f ; arg_rw TraceSession session 
 217      session line (to_string "raw" f) 
 218     
 219    function trace_first u f s 
 220      arg Universal u ; arg Function f ; arg_w Str s 
 221      := to_string "raw" f 
 222     
 223    function trace_next u f s 
 224      arg Universal u ; arg Function f ; arg_rw Str s 
 225      += to_string "raw" f 
 226     
 227    function trace_last u f s slot 
 228      arg Universal u ; arg Function f ; arg Str s ; arg_rw TraceSlot slot 
 229      slot line s+(to_string "raw" f) 
 230   
 231    function trace_last u f s session 
 232      arg Universal u ; arg Function f ; arg Str s ; arg_rw TraceSession session 
 233      session line s+(to_string "raw" f) 
 234   
 235   
 236  meta '. trace' e 
 237    var Link:Argument slot session 
 238    if e:size<2 
 239      return 
 240    eif (e:cast TraceSlot) 
 241      slot :> e:result 
 242      session :> null map Argument 
 243    eif (e:cast TraceSession) 
 244      slot :> null map Argument 
 245      session :> e:result 
 246    else 
 247      return 
 248    if (e:0:access .and. access_write)=0 
 249      return 
 250    if execute 
 251      var Link:Argument cond :> argument indirect CBool (argument local Address) 0 
 252      suckup e:0 
 253      if exists:slot 
 254        add (instruction (the_function '. is_active' TraceSlot -> CBool) e:0:result cond) 
 255      else 
 256        add (instruction (the_function '. is_active' TraceSession -> CBool) e:0:result cond) 
 257      var Link:Instruction end :> instruction the_function:'do nothing' 
 258      add (instruction (the_function 'jump if not' CBool) cond jump end) 
 259    var Int base := 1 
 260    for (var Int i) base e:size-1 
 261      e:compile ? 
 262      var Pointer:Type type :> e:i:result:type:real_data_type 
 263      e:cast type ? 
 264      var Pointer:Function function :> type get_generic_method to_index 
 265      if addressof:function=null or addressof:function=addressof:(the_function '. to string' Universal Str -> Str) 
 266        return 
 267      if execute 
 268        suckup e:i 
 269        if e:size-base=1 
 270          if exists:slot 
 271            add (instruction (the_function trace_single Universal Function TraceSlot) e:i:result (argument mapped_constant Function function) slot) 
 272          else 
 273            add (instruction (the_function trace_single Universal Function TraceSession) e:i:result (argument mapped_constant Function function) session) 
 274        eif i=base 
 275          var Link:Argument buf :> argument local Str 
 276          add (instruction (the_function trace_first Universal Function Str) e:i:result (argument mapped_constant Function function) buf) 
 277        eif i=e:size-1 
 278          if exists:slot 
 279            add (instruction (the_function trace_last Universal Function Str TraceSlot) e:i:result (argument mapped_constant Function function) buf slot) 
 280          else 
 281            add (instruction (the_function trace_last Universal Function Str TraceSession) e:i:result (argument mapped_constant Function function) buf session) 
 282        else 
 283          add (instruction (the_function trace_next Universal Function Str) e:i:result (argument mapped_constant Function function) buf) 
 284    if execute 
 285      add end 
 286    set_void_result 
 287   
 288   
 289  export trace_slots trace_slots_sem trace_memory 
 290  export TraceSlot '. configure' '. reset' '. name' 
 291  export TraceHandler '. bind' '. unbind' '. line' '. flush' 
 292  export TraceSession '. bind' '. flush' '. mark' '. rewind' 
 293  export '. trace' 
 294