meta/meta-40-tc-compiler-15-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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9 ;; currently, debug info is very simple, it contains only PC->LINE mapping
  10 ;;
  11 ;; header:
  12 ;;   dw itemcount        ; files with more that 64kb lines? 'cmon!
  13 ;;   dw firstline        ; files with more that 64kb lines? 'cmon!
  14 ;;   dd filename-c1strz  ; this points to special hidden buffer word, or 0
  15 ;;
  16 ;; items:
  17 ;;   db pcoffs   ; offset from the previous PC (first: from the CFA)
  18 ;;   db lineofs  ; offset from the previous line
  19 ;;
  20 ;; if lineofs is 255, next word is 16-bit line offset
  21 ;; if pcofs is 255, next word is 16-bit line offset
  22 ;;
  23 ;; the compiler doesn't store each PC, it only stores line changes
  24 ;; that is, the range for the line lasts until the next item
  25 ;; items should be sorted by PC (but the code should not fail on
  26 ;; unsorted data)
  27
  28
  29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30 ;; list of known source files
  31 ;; structure:
  32 ;;   dd nextptr     ;; or 0
  33 ;;   dd tcaddr
  34
  35 0 var tc-(dbg-file-list-head)
  36
  37 ;; no checks are made
  38 : tc-(dbg-add-file)  ( addr count -- straddr )
  39   2 cells brk-alloc
  40   tc-(dbg-file-list-head) @ over !
  41   dup tc-(dbg-file-list-head) ! cell+
  42   tc-here swap !
  43   ;; copy string
  44   dup 1+ tc-n-allot dup >r
  45   2dup tc-c! 1+ tc->real swap 0 max cmove
  46   r>
  47 ;
  48
  49 ;; this can return 0
  50 : tc-(dbg-find-or-add-file)  ( addr count -- straddr )
  51   str-extract-name ?dup if
  52     tc-(dbg-file-list-head)
  53     begin
  54       @ ?dup
  55     while
  56       >r 2dup r@ cell+ @ tc->real bcount s= if
  57         2drop r> cell+ @ exit
  58       endif
  59       r>
  60     repeat
  61     ;; add new
  62     tc-(dbg-add-file)
  63   else
  64     drop 0
  65   endif
  66 ;
  67
  68
  69 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  70 ;; create compressed debug info, set dfa
  71
  72 ;; let's use globals here, because why not?
  73 0 value tc-(dbginfo-cpbuf-start)
  74 0 value tc-(dbginfo-cpbuf-curpos)
  75 0 value tc-(dbginfo-cpbuf-currline)
  76 0 value tc-(dbginfo-cpbuf-currpc)
  77
  78 : tc-(dbginfo-build-byte)  ( b -- )
  79   tc-(dbginfo-cpbuf-curpos) c!
  80   tc-(dbginfo-cpbuf-curpos) 1+ to tc-(dbginfo-cpbuf-curpos)
  81 ;
  82
  83 : tc-(dbginfo-build-word)  ( w -- )
  84   dup 0xff and tc-(dbginfo-build-byte)
  85   8 rshift tc-(dbginfo-build-byte)
  86 ;
  87
  88 : tc-(dbginfo-build-dword)  ( dw -- )
  89   dup 0xffff and tc-(dbginfo-build-word)
  90   16 rshift tc-(dbginfo-build-word)
  91 ;
  92
  93
  94 ;; prerequisite: debug info must exist, and must not be empty
  95 : tc-(dbginfo-build-compressed)  ( destbuf -- destbuf size )
  96   ;; build file name (do it here, because it may allocate at here)
  97   forth:(tib-curr-fname) count tc-(dbg-find-or-add-file) >r
  98   ;; init vars
  99   dup to tc-(dbginfo-cpbuf-start)
 100   to tc-(dbginfo-cpbuf-curpos)
 101   ;; get starting line
 102   tc-(dbgbuf-base-addr) @ to tc-(dbginfo-cpbuf-currline)
 103   ;; get starting PC
 104   tc-latest-cfa to tc-(dbginfo-cpbuf-currpc)
 105   ;; create header
 106   ;; item count (we know that in advance)
 107   tc-(dbgbuf-curr-addr) @ tc-(dbgbuf-base-addr) - 3 rshift tc-(dbginfo-build-word)
 108   ;; first line
 109   tc-(dbginfo-cpbuf-currline) tc-(dbginfo-build-word)
 110   ;; file name
 111   r> tc-(dbginfo-build-dword)
 112   tc-(dbgbuf-curr-addr) @ tc-(dbgbuf-base-addr) do
 113     ;;   db pcoffs   ; offset from the previous PC (first: from the CFA)
 114     ;;   db lineofs  ; offset from the previous line
 115     ;;
 116     ;; if lineofs is 255, next word is 16-bit line offset
 117     ;; if pcofs is 255, next word is 16-bit line offset
 118     ;; PC
 119     i cell+ @ tc-(dbginfo-cpbuf-currpc) - dup 255 < if
 120       ;; 8-bit offset
 121       tc-(dbginfo-build-byte)
 122     else
 123       ;; 16-bit offset
 124       255 tc-(dbginfo-build-byte)
 125       tc-(dbginfo-build-word)
 126     endif
 127     ;; update current PC
 128     i cell+ @ to tc-(dbginfo-cpbuf-currpc)
 129     ;; line number
 130     i @ tc-(dbginfo-cpbuf-currline) - dup 255 < if
 131       ;; 8-bit offset
 132       tc-(dbginfo-build-byte)
 133     else
 134       ;; 16-bit offset
 135       255 tc-(dbginfo-build-byte)
 136       tc-(dbginfo-build-word)
 137     endif
 138     ;; update current line
 139       \ endcr i @ . tc-(dbginfo-cpbuf-currline) . cr
 140     i @ to tc-(dbginfo-cpbuf-currline)
 141   2 cells +loop
 142   ;; return addr and size
 143   tc-(dbginfo-cpbuf-start) tc-(dbginfo-cpbuf-curpos) over -
 144 ;
 145
 146 : tc-(dbginfo-finalize-and-copy)  ( -- )
 147   tc-(dbginfo-active?) tc-(dbginfo-enabled?) logand if
 148     tc-(dbgbuf-base-addr) ?dup if
 149       @ if
 150         ;; save current PC
 151         tc-(dbgbuf-curr-addr) @ 0! tc-(dbginfo-add-here)
 152         ;; compressed should never be bigger than the original
 153         tc-(dbgbuf-curr-addr) @ tc-(dbgbuf-base-addr) - 4 +cells dup >r
 154         os:prot-r/w os:mmap not-?abort" out of memory" dup >r
 155         tc-(dbginfo-build-compressed)
 156           \ endcr ." debug: from " tc-(dbgbuf-curr-addr) @ tc-(dbgbuf-base-addr) - . ." to " dup . cr
 157         ;; save here to debug info field
 158         tc-here tc-latest-nfa tc-nfa->dfa tc-!
 159         dup tc-n-allot  ;; ( addr bytes rva-newaddr )
 160         tc->real swap 0 max cmove
 161         r> r> swap os:munmap drop
 162       else
 163         drop
 164       endif
 165     endif
 166   endif
 167   ;; always deactivate
 168   tc-(dbginfo-reset)
 169 ;