libs/ufe/zxtrace_lib.f

   1 ;; ////////////////////////////////////////////////////////////////////////// //
   2 0 VALUE ZX-TRACER-SAVED-DP
   3 0 VALUE ZX-TRACER-WORD-START  ;; always ZX address
   4 0 VALUE ZX-TRACER-WORD-END    ;; always ZX address
   5
   6 ;; flags
   7 ;;   bit 0: branch
   8 ;;   bit 1: numlit
   9 ;;   bit 2: strlit
  10 ;;   bit 3: noreturn
  11 ;;   bit 4: noturnkey
  12 ;;   bit 5: immediate
  13 ;;   bit 6: unconditional branch
  14 ;;   bit 7: used mark
  15
  16
  17 ;; ////////////////////////////////////////////////////////////////////////// //
  18 : (ZX-WRITE-#HEX4) ( n -- )
  19   BASE @ HEX SWAP
  20   <# # # # # [CHAR] # HOLD #> TYPE
  21   BASE !
  22 ;
  23
  24
  25 : (ZX-WRITE-HEX4) ( n -- )
  26   BASE @ HEX SWAP
  27   <# # # # # #> TYPE
  28   BASE !
  29 ;
  30
  31
  32 ;; ////////////////////////////////////////////////////////////////////////// //
  33 : ZX-LABELS-COUNT ( -- addr )
  34   ZX-TRACER-SAVED-DP @
  35 ;
  36
  37 : ZX-LABELS-START-ADDR ( -- addr )
  38   ZX-TRACER-SAVED-DP 1+
  39 ;
  40
  41 : ZX-LABELS-END-ADDR ( -- addr )
  42   ZX-LABELS-START-ADDR ZX-LABELS-COUNT +
  43 ;
  44
  45 : ZX-HAS-LABEL-AT ( addr -- flag )
  46   ZX-LABELS-COUNT IFNOT DROP 0 EXIT ENDIF
  47   TOZX
  48   ZX-LABELS-END-ADDR ZX-LABELS-START-ADDR
  49   DO
  50     DUP I @ = IF DROP RDROP RDROP 1 EXIT ENDIF
  51   LOOP
  52   DROP 0
  53 ;
  54
  55 : ZX-HAS-LABEL-AFTER ( addr -- flag )
  56   ZX-LABELS-COUNT IFNOT DROP 0 EXIT ENDIF
  57   TOZX
  58   ZX-LABELS-END-ADDR ZX-LABELS-START-ADDR
  59   DO
  60     DUP I @ U< IF DROP RDROP RDROP 1 EXIT ENDIF
  61   LOOP
  62   DROP 0
  63 ;
  64
  65 : ZX-APPEND-LABEL ( addr -- )
  66     \ DUP ." checking label: #" HEX U. DECIMAL ZX-TRACER-SAVED-DP @ ." (labels:" 0 .R ." )\n"
  67   DUP ZX-HAS-LABEL-AT IF
  68       \ DUP ." duplicate label: #" HEX U. DECIMAL CR
  69     DROP
  70   ELSE
  71       \ DUP ." new label: #" HEX U. DECIMAL CR
  72     ZX-TRACER-SAVED-DP 1+!
  73     TOZX ,
  74   ENDIF
  75 ;
  76
  77
  78 ;; ////////////////////////////////////////////////////////////////////////// //
  79 : ZX-TRACE-SKIP-INSTR ( pfa -- nextpfa )
  80   DUP @ UR-ZX-WORD-FLAGS-BY-CFA SWAP 2+
  81   ;; ( flags pfa )
  82   OVER FWF-CODEBLOCK AND IF 5 + SWAP DROP 0 SWAP ENDIF
  83   OVER FWF-BRANCH FWF-NUMLIT OR FWF-COMPILE OR AND IF 2+ ENDIF
  84   OVER FWF-STRLIT AND IF ZX-BCOUNT + ENDIF
  85   SWAP DROP
  86 ;
  87
  88
  89 : ZX-PRINT-INSTR-ARGS ( pfa -- )
  90   DUP @ UR-ZX-WORD-FLAGS-BY-CFA SWAP 2+
  91   ;; ( flags pfa )
  92   ;; codeblock?
  93   OVER FWF-CODEBLOCK AND IF
  94     ;; codeblock is followed by jump destination, then cfa, then threaded code
  95     ."  L" @ (ZX-WRITE-HEX4)
  96     DROP EXIT
  97   ENDIF
  98   ;; branch?
  99   OVER FWF-BRANCH AND IF
 100     ."  L" @ (ZX-WRITE-HEX4)
 101     DROP EXIT
 102   ENDIF
 103   ;; numlit?
 104   OVER FWF-NUMLIT AND IF
 105     @ SPACE 0 U.R
 106     DROP EXIT
 107   ENDIF
 108   ;; strlit?
 109   OVER FWF-STRLIT AND IF
 110     ZX-BCOUNT ."  ~" XTYPE ." ~"
 111     DROP EXIT
 112   ENDIF
 113   ;; compile?
 114   OVER FWF-COMPILE AND IF
 115     @ UR-ZX-WORD-NAME-BY-CFA IF SPACE XTYPE ELSE ."  ???" ENDIF
 116     DROP EXIT
 117   ENDIF
 118   2DROP
 119 ;
 120
 121
 122 ;; ////////////////////////////////////////////////////////////////////////// //
 123 : ZX-TRACE-LABELS ( pfa -- )
 124   DUP TO ZX-TRACER-WORD-START
 125   0 ,  ;; label count
 126   BEGIN
 127     ;; ( pfa )
 128     DUP @  ;; ( pfa cfa )
 129     UR-ZX-WORD-FLAGS-BY-CFA
 130     SWAP 2+ ;; move to the next word
 131     ;; ( flags pfa )
 132     ;; codeblock?
 133     OVER FWF-CODEBLOCK AND IF
 134       ;; codeblock is followed by jump destination, then cfa, then threaded code
 135       ;; it is guaranteed to jump forward, so take a shortcut here
 136       DUP @ ZX-APPEND-LABEL  ;; append label
 137       4+  ;; skip branch and CFA; we want to continue tracing inside a codeblock anyway
 138       ;; no need to anaylze it further
 139       SWAP DROP 0 SWAP
 140     ENDIF
 141     ;; branch?
 142     OVER FWF-BRANCH AND IF
 143       DUP @ ZX-APPEND-LABEL
 144       2+  ;; skip branch destination
 145       ;; check if this is backward unconditional branch
 146       OVER FWF-UNCONDITIONAL AND IF
 147         ;; check if this is backward branch
 148         ;; ( flags pfa )
 149         DUP 2- @ TOZX  ;; ( flags pfa dest )
 150         OVER TOZX      ;; ( flags pfa dest pfa )
 151         ;; ( flags pfa dest pfa )
 152         U<= IF
 153           ;; check if we should stop here
 154           ;; ( flags pfa )
 155           DUP ZX-HAS-LABEL-AFTER
 156           IFNOT
 157             ;; no more code
 158             TO ZX-TRACER-WORD-END
 159             DROP EXIT
 160           ENDIF
 161         ENDIF
 162       ENDIF
 163       SWAP FWF-NORETURN BITNOT AND SWAP
 164     ENDIF
 165     ;; numlit?
 166     OVER FWF-NUMLIT AND IF
 167       2+
 168     ENDIF
 169     ;; strlit?
 170     OVER FWF-STRLIT AND IF
 171       ZX-BCOUNT +
 172     ENDIF
 173     ;; compile?
 174     OVER FWF-COMPILE AND IF
 175       2+
 176     ENDIF
 177     ;; noreturn?
 178     OVER FWF-NORETURN AND IF
 179       ;; ( flags pfa )
 180       ;; check if we have any label after this word
 181       DUP 2- ZX-HAS-LABEL-AFTER
 182       IFNOT
 183         TO ZX-TRACER-WORD-END
 184         DROP EXIT
 185       ENDIF
 186     ENDIF
 187     SWAP DROP  ;; drop flags
 188   AGAIN
 189 ;
 190
 191
 192 ;; ////////////////////////////////////////////////////////////////////////// //
 193 ;; labels must be already traced
 194 : (ZX-DECOMP)  ( pfa -- )
 195   DUP 3- UR-ZX-WORD-NAME-BY-CFA IFNOT " WTF??!" UFE-FATAL ENDIF ." === " TYPE ."  ===\n"
 196   BEGIN
 197     DUP ZX-TRACER-WORD-END U<
 198   WHILE
 199     ;; address
 200     DUP (ZX-WRITE-#HEX4) ." :"
 201     ;; has label?
 202     DUP ZX-HAS-LABEL-AT IF
 203       ." L" DUP (ZX-WRITE-HEX4) CR
 204       DUP (ZX-WRITE-#HEX4) ." : "
 205     ELSE
 206       SPACE
 207     ENDIF
 208     ;; word name
 209     DUP @ UR-ZX-WORD-NAME-BY-CFA IFNOT " WTF?!" UFE-FATAL ENDIF XTYPE
 210     ;; word args
 211     DUP ZX-PRINT-INSTR-ARGS
 212     CR
 213     ZX-TRACE-SKIP-INSTR
 214   REPEAT
 215   DROP
 216 ;