basis/tools/trace/trace.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: concurrency.promises models tools.continuations kernel
   4 sequences concurrency.messaging locals continuations threads
   5 namespaces namespaces.private make assocs accessors io strings
   6 prettyprint math math.parser words effects summary io.styles classes
   7 generic.math combinators.short-circuit kernel.private quotations ;
   8 IN: tools.trace
   9
  10 SYMBOL: exclude-vocabs
  11 SYMBOL: include-vocabs
  12
  13 exclude-vocabs { "math" "accessors" } swap set-global
  14
  15 <PRIVATE
  16
  17 : callstack-depth ( callstack -- n )
  18     callstack>array midpoint@ ;
  19
  20 SYMBOL: end
  21
  22 : include? ( vocab -- ? )
  23     include-vocabs get dup [ member? ] [ 2drop t ] if ;
  24
  25 : exclude? ( vocab -- ? )
  26     exclude-vocabs get dup [ member? ] [ 2drop f ] if ;
  27
  28 : into? ( obj -- ? )
  29     {
  30         [ word? ]
  31         [ predicate? not ]
  32         [ math-generic? not ]
  33         [
  34             {
  35                 [ inline? ]
  36                 [
  37                     {
  38                         [ vocabulary>> include? ]
  39                         [ vocabulary>> exclude? not ]
  40                     } 1&&
  41                 ]
  42             } 1||
  43         ]
  44     } 1&& ;
  45
  46 TUPLE: trace-step word inputs ;
  47
  48 M: trace-step summary
  49     [
  50         [ "Word: " % word>> name>> % ]
  51         [ " -- inputs: " % inputs>> unparse-short % ] bi
  52     ] "" make ;
  53
  54 : <trace-step> ( continuation word -- trace-step )
  55     [ nip ] [ [ data>> ] [ stack-effect in>> length ] bi* short tail* ] 2bi
  56     \ trace-step boa ;
  57
  58 : print-step ( continuation -- )
  59     dup continuation-current dup word? [
  60         [ nip name>> ] [ <trace-step> ] 2bi write-object nl
  61     ] [
  62         nip short.
  63     ] if ;
  64
  65 : print-depth ( continuation -- )
  66     call>> callstack-depth
  67     [ CHAR: \s <string> write ]
  68     [ number>string write ": " write ] bi ;
  69
  70 : trace-into? ( continuation -- ? )
  71     continuation-current into? ;
  72
  73 : trace-step ( continuation -- continuation' )
  74     dup call>> innermost-frame-executing quotation? [
  75         dup continuation-current end eq? [
  76             [ print-depth ]
  77             [ print-step ]
  78             [ dup trace-into? [ continuation-step-into ] [ continuation-step ] if ]
  79             tri
  80         ] unless
  81     ] when ;
  82
  83 PRIVATE>
  84
  85 : trace ( quot -- data )
  86     [ [ trace-step ] break-hook ] dip
  87     [ break ] [ end drop ] surround
  88     with-variable ;
  89
  90 << \ trace t "no-compile" set-word-prop >>