meta/meta-40-tc-compiler-00-dbginfo.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Metacompiler
   4 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   5 ;; GPLv3 ONLY
   6 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   7
   8 1024 64 * constant tc-(dbgbuf-maxsize) (hidden)
   9 true value tc-(dbginfo-enabled?) (hidden)
  10 false value tc-(dbginfo-active?) (hidden)
  11 0 value tc-(dbgbuf-base-addr) (hidden)
  12 0 value tc-(dbgbuf-end-addr) (hidden)
  13 0 var tc-(dbgbuf-curr-addr) (hidden)
  14
  15
  16 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17 : tc-debug-info-on  ( -- )
  18   tc-debugger-enabled to tc-(dbginfo-enabled?)
  19 ;
  20
  21 : tc-debug-info-off  ( -- )
  22   false to tc-(dbginfo-enabled?)
  23 ;
  24
  25
  26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27 : tc-(dbginfo-reset)  ( -- )
  28   tc-(dbgbuf-base-addr) tc-(dbgbuf-curr-addr) !
  29   false to tc-(dbginfo-active?)
  30   ;; set first line to 0 (to ease checks in "add-pc")
  31   tc-(dbgbuf-base-addr) ?dup if 0! endif
  32   tc-debugger-enabled to tc-(dbginfo-enabled?)
  33 ; (hidden)
  34
  35
  36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37 : tc-debug-initialize  ( -- )
  38   tc-(dbgbuf-base-addr) ?abort" debuginfo writer already initialized"
  39   tc-(dbgbuf-maxsize) 0< ?abort" debuginfo writer: invalid config"
  40   tc-(dbgbuf-maxsize) ?dup if
  41     brk-alloc dup to tc-(dbgbuf-base-addr)
  42     tc-(dbgbuf-maxsize) + to tc-(dbgbuf-end-addr)
  43   else
  44     false to tc-(dbginfo-enabled?)
  45   endif
  46   tc-(dbginfo-reset)
  47 ;
  48
  49
  50 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  51 ;; this stores line and PC (in this order) as dwords
  52 : tc-(dbginfo-add-pc)  ( pc line -- )
  53   ;; never put zero line
  54   ?dup ifnot drop exit endif
  55   ;; special? -1 items means "out of room"
  56   tc-(dbgbuf-curr-addr) @ ?dup ifnot 2drop exit endif
  57   ;; ( pc line dbgbufaddr )
  58   ;; check if the line is the same (if we have no lines, there will be zero)
  59   2dup @ = if drop 2drop exit endif
  60   ;; check if we have enough room
  61   dup 3 +cells tc-(dbgbuf-end-addr) u> if
  62     ;; out of buffer, abort debug info generation
  63     drop 2drop tc-(dbgbuf-curr-addr) 0!
  64     exit
  65   endif
  66   ;; put line and pc
  67   ;; ( pc line dbgbufaddr )
  68   swap over ! cell+  ;; line
  69   swap over ! cell+  ;; pc
  70   ;; put current line number to the next item (for equality check above)
  71   dup 2 -cells @ over !
  72   tc-(dbgbuf-curr-addr) !
  73 ; (hidden)
  74
  75
  76 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  77 : tc-(dbginfo-add-here)  ( -- )
  78   ;; put debug info
  79   tc-(dbginfo-active?) tc-(dbginfo-enabled?) logand if
  80     elf-current-pc ;; tc-here -- sorry
  81     tib-line# @ (tib-last-read-char) @ 10 = if 1- 0 max endif
  82     tc-(dbginfo-add-pc)
  83   endif
  84 ;
  85
  86
  87 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  88 tc-debug-initialize