dwarf.scm 58 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851
  1. ;;; Guile DWARF reader and writer
  2. ;; Copyright (C) 2012, 2013 Free Software Foundation, Inc.
  3. ;; Parts of this file were derived from sysdeps/generic/dwarf2.h, from
  4. ;; the GNU C Library. That file is available under the LGPL version 2
  5. ;; or later, and is copyright:
  6. ;;
  7. ;; Copyright (C) 1992, 1993, 1995, 1996, 1997, 2000, 2011
  8. ;; Free Software Foundation, Inc.
  9. ;; Contributed by Gary Funck (gary@intrepid.com). Derived from the
  10. ;; DWARF 1 implementation written by Ron Guilmette (rfg@monkeys.com).
  11. ;;;; This library is free software; you can redistribute it and/or
  12. ;;;; modify it under the terms of the GNU Lesser General Public
  13. ;;;; License as published by the Free Software Foundation; either
  14. ;;;; version 3 of the License, or (at your option) any later version.
  15. ;;;;
  16. ;;;; This library is distributed in the hope that it will be useful,
  17. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  19. ;;;; Lesser General Public License for more details.
  20. ;;;;
  21. ;;;; You should have received a copy of the GNU Lesser General Public
  22. ;;;; License along with this library; if not, write to the Free Software
  23. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  24. ;;; Commentary:
  25. ;;
  26. ;; DWARF is a flexible format for describing compiled programs. It is
  27. ;; used by Guile to record source positions, describe local variables,
  28. ;; function arities, and other function metadata.
  29. ;;
  30. ;; Structurally, DWARF describes a tree of data. Each node in the tree
  31. ;; is a debugging information entry ("DIE"). Each DIE has a "tag",
  32. ;; possible a set of attributes, and possibly some child DIE nodes.
  33. ;; That's basically it!
  34. ;;
  35. ;; The DIE nodes are contained in the .debug_info section of an ELF
  36. ;; file. Attributes within the DIE nodes link them to mapped ranges of
  37. ;; the ELF file (.rtl-text, .data, etc.).
  38. ;;
  39. ;; A .debug_info section logically contains a series of debugging
  40. ;; "contributions", one for each compilation unit. Each contribution is
  41. ;; prefixed by a header and contains a single DIE element whose tag is
  42. ;; "compilation-unit". That node usually contains child nodes, for
  43. ;; example of type "subprogram".
  44. ;;
  45. ;; Since usually one will end up producing many DIE nodes with the same
  46. ;; tag and attribute types, DIE nodes are defined by referencing a known
  47. ;; shape, and then filling in the values. The shapes are defined in the
  48. ;; form of "abbrev" entries, which specify a specific combination of a
  49. ;; tag and an ordered set of attributes, with corresponding attribute
  50. ;; representations ("forms"). Abbrevs are written out to a separate
  51. ;; section, .debug_abbrev. Abbrev nodes also specify whether the
  52. ;; corresponding DIE node has children or not. When a DIE is written
  53. ;; into the .debug_info section, it references one of the abbrevs in
  54. ;; .debug_abbrev. You need the abbrev in order to parse the DIE.
  55. ;;
  56. ;; For completeness, the other sections that DWARF uses are .debug_str,
  57. ;; .debug_loc, .debug_pubnames, .debug_aranges, .debug_frame, and
  58. ;; .debug_line. These are described in section 6 of the DWARF 3.0
  59. ;; specification, at http://dwarfstd.org/.
  60. ;;
  61. ;; This DWARF module is currently capable of parsing all of DWARF 2.0
  62. ;; and parts of DWARF 3.0. For Guile's purposes, we also use DWARF as
  63. ;; the format for our own debugging information. The DWARF generator is
  64. ;; fairly minimal, and is not intended to be complete.
  65. ;;
  66. ;;; Code:
  67. (define-module (system vm dwarf)
  68. #:use-module (rnrs bytevectors)
  69. #:use-module (system vm elf)
  70. #:use-module ((srfi srfi-1) #:select (fold))
  71. #:use-module (srfi srfi-9)
  72. #:use-module (srfi srfi-9 gnu)
  73. #:use-module (srfi srfi-11)
  74. #:export (elf->dwarf-context
  75. read-die-roots
  76. fold-pubnames fold-aranges
  77. access-name->code
  78. address-name->code
  79. attribute-name->code
  80. call-frame-address-name->code
  81. children-name->code
  82. convention-name->code
  83. discriminant-name->code
  84. form-name->code
  85. inline-name->code
  86. language-name->code
  87. macro-name->code
  88. ordering-name->code
  89. sensitivity-name->code
  90. tag-name->code
  91. virtuality-name->code
  92. visibility-name->code
  93. abbrev? abbrev-code
  94. abbrev-tag abbrev-has-children? abbrev-attrs abbrev-forms
  95. die? die-ctx die-offset die-abbrev die-vals die-children
  96. die-tag die-attrs die-forms die-ref
  97. die-name die-specification die-qname die-low-pc die-high-pc
  98. ctx-parent ctx-die ctx-start ctx-end ctx-children ctx-language
  99. die-line-prog line-prog-advance line-prog-scan-to-pc
  100. find-die-context find-die-by-offset find-die find-die-by-pc
  101. read-die fold-die-list
  102. fold-die-children die->tree))
  103. ;;;
  104. ;;; First, define a number of constants. The figures numbers refer to
  105. ;;; the DWARF 2.0 draft specification available on http://dwarfstd.org/.
  106. ;;; Extra codes not defined in that document are taken from the dwarf2
  107. ;;; header in glibc.
  108. ;;;
  109. (define-syntax-rule (define-enumeration code->name name->code
  110. (tag value) ...)
  111. (begin
  112. (define code->name
  113. (let ((table (make-hash-table)))
  114. (hashv-set! table value 'tag)
  115. ...
  116. (lambda (v)
  117. (hashv-ref table v v))))
  118. (define name->code
  119. (let ((table (make-hash-table)))
  120. (hashv-set! table 'tag value)
  121. ...
  122. (lambda (v)
  123. (hashv-ref table v v))))))
  124. ;; Figures 14 and 15: Tag names and codes.
  125. ;;
  126. (define-enumeration tag-code->name tag-name->code
  127. (padding #x00)
  128. (array-type #x01)
  129. (class-type #x02)
  130. (entry-point #x03)
  131. (enumeration-type #x04)
  132. (formal-parameter #x05)
  133. (imported-declaration #x08)
  134. (label #x0a)
  135. (lexical-block #x0b)
  136. (member #x0d)
  137. (pointer-type #x0f)
  138. (reference-type #x10)
  139. (compile-unit #x11)
  140. (string-type #x12)
  141. (structure-type #x13)
  142. (subroutine-type #x15)
  143. (typedef #x16)
  144. (union-type #x17)
  145. (unspecified-parameters #x18)
  146. (variant #x19)
  147. (common-block #x1a)
  148. (common-inclusion #x1b)
  149. (inheritance #x1c)
  150. (inlined-subroutine #x1d)
  151. (module #x1e)
  152. (ptr-to-member-type #x1f)
  153. (set-type #x20)
  154. (subrange-type #x21)
  155. (with-stmt #x22)
  156. (access-declaration #x23)
  157. (base-type #x24)
  158. (catch-block #x25)
  159. (const-type #x26)
  160. (constant #x27)
  161. (enumerator #x28)
  162. (file-type #x29)
  163. (friend #x2a)
  164. (namelist #x2b)
  165. (namelist-item #x2c)
  166. (packed-type #x2d)
  167. (subprogram #x2e)
  168. (template-type-param #x2f)
  169. (template-value-param #x30)
  170. (thrown-type #x31)
  171. (try-block #x32)
  172. (variant-part #x33)
  173. (variable #x34)
  174. (volatile-type #x35)
  175. ;; DWARF 3.
  176. (dwarf-procedure #x36)
  177. (restrict-type #x37)
  178. (interface-type #x38)
  179. (namespace #x39)
  180. (imported-module #x3a)
  181. (unspecified-type #x3b)
  182. (partial-unit #x3c)
  183. (imported-unit #x3d)
  184. (condition #x3f)
  185. (shared-type #x40)
  186. ;; Extensions.
  187. (format-label #x4101)
  188. (function-template #x4102)
  189. (class-template #x4103)
  190. (GNU-BINCL #x4104)
  191. (GNU-EINCL #x4105)
  192. (lo-user #x4080)
  193. (hi-user #xffff))
  194. ;; Figure 16: Flag that tells whether entry has a child or not.
  195. ;;
  196. (define-enumeration children-code->name children-name->code
  197. (no 0)
  198. (yes 1))
  199. ;; Figures 17 and 18: Attribute names and codes.
  200. ;;
  201. (define-enumeration attribute-code->name attribute-name->code
  202. (sibling #x01)
  203. (location #x02)
  204. (name #x03)
  205. (ordering #x09)
  206. (subscr-data #x0a)
  207. (byte-size #x0b)
  208. (bit-offset #x0c)
  209. (bit-size #x0d)
  210. (element-list #x0f)
  211. (stmt-list #x10)
  212. (low-pc #x11)
  213. (high-pc #x12)
  214. (language #x13)
  215. (member #x14)
  216. (discr #x15)
  217. (discr-value #x16)
  218. (visibility #x17)
  219. (import #x18)
  220. (string-length #x19)
  221. (common-reference #x1a)
  222. (comp-dir #x1b)
  223. (const-value #x1c)
  224. (containing-type #x1d)
  225. (default-value #x1e)
  226. (inline #x20)
  227. (is-optional #x21)
  228. (lower-bound #x22)
  229. (producer #x25)
  230. (prototyped #x27)
  231. (return-addr #x2a)
  232. (start-scope #x2c)
  233. (stride-size #x2e)
  234. (upper-bound #x2f)
  235. (abstract-origin #x31)
  236. (accessibility #x32)
  237. (address-class #x33)
  238. (artificial #x34)
  239. (base-types #x35)
  240. (calling-convention #x36)
  241. (count #x37)
  242. (data-member-location #x38)
  243. (decl-column #x39)
  244. (decl-file #x3a)
  245. (decl-line #x3b)
  246. (declaration #x3c)
  247. (discr-list #x3d)
  248. (encoding #x3e)
  249. (external #x3f)
  250. (frame-base #x40)
  251. (friend #x41)
  252. (identifier-case #x42)
  253. (macro-info #x43)
  254. (namelist-items #x44)
  255. (priority #x45)
  256. (segment #x46)
  257. (specification #x47)
  258. (static-link #x48)
  259. (type #x49)
  260. (use-location #x4a)
  261. (variable-parameter #x4b)
  262. (virtuality #x4c)
  263. (vtable-elem-location #x4d)
  264. ;; DWARF 3.
  265. (associated #x4f)
  266. (data-location #x50)
  267. (byte-stride #x51)
  268. (entry-pc #x52)
  269. (use-UTF8 #x53)
  270. (extension #x54)
  271. (ranges #x55)
  272. (trampoline #x56)
  273. (call-column #x57)
  274. (call-file #x58)
  275. (call-line #x59)
  276. (description #x5a)
  277. (binary-scale #x5b)
  278. (decimal-scale #x5c)
  279. (small #x5d)
  280. (decimal-sign #x5e)
  281. (digit-count #x5f)
  282. (picture-string #x60)
  283. (mutable #x61)
  284. (threads-scaled #x62)
  285. (explicit #x63)
  286. (object-pointer #x64)
  287. (endianity #x65)
  288. (elemental #x66)
  289. (pure #x67)
  290. (recursive #x68)
  291. ;; Extensions.
  292. (linkage-name #x2007)
  293. (sf-names #x2101)
  294. (src-info #x2102)
  295. (mac-info #x2103)
  296. (src-coords #x2104)
  297. (body-begin #x2105)
  298. (body-end #x2106)
  299. (lo-user #x2000)
  300. (hi-user #x3fff))
  301. ;; Figure 19: Form names and codes.
  302. ;;
  303. (define-enumeration form-code->name form-name->code
  304. (addr #x01)
  305. (block2 #x03)
  306. (block4 #x04)
  307. (data2 #x05)
  308. (data4 #x06)
  309. (data8 #x07)
  310. (string #x08)
  311. (block #x09)
  312. (block1 #x0a)
  313. (data1 #x0b)
  314. (flag #x0c)
  315. (sdata #x0d)
  316. (strp #x0e)
  317. (udata #x0f)
  318. (ref-addr #x10)
  319. (ref1 #x11)
  320. (ref2 #x12)
  321. (ref4 #x13)
  322. (ref8 #x14)
  323. (ref-udata #x15)
  324. (indirect #x16)
  325. (sec-offset #x17)
  326. (exprloc #x18)
  327. (flag-present #x19)
  328. (ref-sig8 #x20))
  329. ;; Figures 22 and 23: Location atom names and codes.
  330. ;;
  331. (define-enumeration location-op->name location-name->op
  332. (addr #x03)
  333. (deref #x06)
  334. (const1u #x08)
  335. (const1s #x09)
  336. (const2u #x0a)
  337. (const2s #x0b)
  338. (const4u #x0c)
  339. (const4s #x0d)
  340. (const8u #x0e)
  341. (const8s #x0f)
  342. (constu #x10)
  343. (consts #x11)
  344. (dup #x12)
  345. (drop #x13)
  346. (over #x14)
  347. (pick #x15)
  348. (swap #x16)
  349. (rot #x17)
  350. (xderef #x18)
  351. (abs #x19)
  352. (and #x1a)
  353. (div #x1b)
  354. (minus #x1c)
  355. (mod #x1d)
  356. (mul #x1e)
  357. (neg #x1f)
  358. (not #x20)
  359. (or #x21)
  360. (plus #x22)
  361. (plus-uconst #x23)
  362. (shl #x24)
  363. (shr #x25)
  364. (shra #x26)
  365. (xor #x27)
  366. (bra #x28)
  367. (eq #x29)
  368. (ge #x2a)
  369. (gt #x2b)
  370. (le #x2c)
  371. (lt #x2d)
  372. (ne #x2e)
  373. (skip #x2f)
  374. (lit0 #x30)
  375. (lit1 #x31)
  376. (lit2 #x32)
  377. (lit3 #x33)
  378. (lit4 #x34)
  379. (lit5 #x35)
  380. (lit6 #x36)
  381. (lit7 #x37)
  382. (lit8 #x38)
  383. (lit9 #x39)
  384. (lit10 #x3a)
  385. (lit11 #x3b)
  386. (lit12 #x3c)
  387. (lit13 #x3d)
  388. (lit14 #x3e)
  389. (lit15 #x3f)
  390. (lit16 #x40)
  391. (lit17 #x41)
  392. (lit18 #x42)
  393. (lit19 #x43)
  394. (lit20 #x44)
  395. (lit21 #x45)
  396. (lit22 #x46)
  397. (lit23 #x47)
  398. (lit24 #x48)
  399. (lit25 #x49)
  400. (lit26 #x4a)
  401. (lit27 #x4b)
  402. (lit28 #x4c)
  403. (lit29 #x4d)
  404. (lit30 #x4e)
  405. (lit31 #x4f)
  406. (reg0 #x50)
  407. (reg1 #x51)
  408. (reg2 #x52)
  409. (reg3 #x53)
  410. (reg4 #x54)
  411. (reg5 #x55)
  412. (reg6 #x56)
  413. (reg7 #x57)
  414. (reg8 #x58)
  415. (reg9 #x59)
  416. (reg10 #x5a)
  417. (reg11 #x5b)
  418. (reg12 #x5c)
  419. (reg13 #x5d)
  420. (reg14 #x5e)
  421. (reg15 #x5f)
  422. (reg16 #x60)
  423. (reg17 #x61)
  424. (reg18 #x62)
  425. (reg19 #x63)
  426. (reg20 #x64)
  427. (reg21 #x65)
  428. (reg22 #x66)
  429. (reg23 #x67)
  430. (reg24 #x68)
  431. (reg25 #x69)
  432. (reg26 #x6a)
  433. (reg27 #x6b)
  434. (reg28 #x6c)
  435. (reg29 #x6d)
  436. (reg30 #x6e)
  437. (reg31 #x6f)
  438. (breg0 #x70)
  439. (breg1 #x71)
  440. (breg2 #x72)
  441. (breg3 #x73)
  442. (breg4 #x74)
  443. (breg5 #x75)
  444. (breg6 #x76)
  445. (breg7 #x77)
  446. (breg8 #x78)
  447. (breg9 #x79)
  448. (breg10 #x7a)
  449. (breg11 #x7b)
  450. (breg12 #x7c)
  451. (breg13 #x7d)
  452. (breg14 #x7e)
  453. (breg15 #x7f)
  454. (breg16 #x80)
  455. (breg17 #x81)
  456. (breg18 #x82)
  457. (breg19 #x83)
  458. (breg20 #x84)
  459. (breg21 #x85)
  460. (breg22 #x86)
  461. (breg23 #x87)
  462. (breg24 #x88)
  463. (breg25 #x89)
  464. (breg26 #x8a)
  465. (breg27 #x8b)
  466. (breg28 #x8c)
  467. (breg29 #x8d)
  468. (breg30 #x8e)
  469. (breg31 #x8f)
  470. (regx #x90)
  471. (fbreg #x91)
  472. (bregx #x92)
  473. (piece #x93)
  474. (deref-size #x94)
  475. (xderef-size #x95)
  476. (nop #x96)
  477. ;; DWARF 3.
  478. (push-object-address #x97)
  479. (call2 #x98)
  480. (call4 #x99)
  481. (call-ref #x9a)
  482. (form-tls-address #x9b)
  483. (call-frame-cfa #x9c)
  484. (bit-piece #x9d)
  485. (lo-user #x80)
  486. (hi-user #xff))
  487. ;; Figure 24: Type encodings.
  488. ;;
  489. (define-enumeration type-encoding->name type-name->encoding
  490. (void #x0)
  491. (address #x1)
  492. (boolean #x2)
  493. (complex-float #x3)
  494. (float #x4)
  495. (signed #x5)
  496. (signed-char #x6)
  497. (unsigned #x7)
  498. (unsigned-char #x8)
  499. ;; DWARF 3.
  500. (imaginary-float #x09)
  501. (packed-decimal #x0a)
  502. (numeric-string #x0b)
  503. (edited #x0c)
  504. (signed-fixed #x0d)
  505. (unsigned-fixed #x0e)
  506. (decimal-float #x0f)
  507. (lo-user #x80)
  508. (hi-user #xff))
  509. ;; Figure 25: Access attribute.
  510. ;;
  511. (define-enumeration access-code->name access-name->code
  512. (public 1)
  513. (protected 2)
  514. (private 3))
  515. ;; Figure 26: Visibility.
  516. ;;
  517. (define-enumeration visibility-code->name visibility-name->code
  518. (local 1)
  519. (exported 2)
  520. (qualified 3))
  521. ;; Figure 27: Virtuality.
  522. ;;
  523. (define-enumeration virtuality-code->name virtuality-name->code
  524. (none 0)
  525. (virtual 1)
  526. (pure-virtual 2))
  527. ;; Figure 28: Source language names and codes.
  528. ;;
  529. (define-enumeration language-code->name language-name->code
  530. (c89 #x0001)
  531. (c #x0002)
  532. (ada83 #x0003)
  533. (c++ #x0004)
  534. (cobol74 #x0005)
  535. (cobol85 #x0006)
  536. (fortran77 #x0007)
  537. (fortran90 #x0008)
  538. (pascal83 #x0009)
  539. (modula2 #x000a)
  540. (java #x000b)
  541. (c99 #x000c)
  542. (ada95 #x000d)
  543. (fortran95 #x000e)
  544. (pli #x000f)
  545. (objc #x0010)
  546. (objc++ #x0011)
  547. (upc #x0012)
  548. (d #x0013)
  549. (python #x0014)
  550. (mips-assembler #x8001)
  551. (lo-user #x8000)
  552. ;; FIXME: Ask for proper codes for these.
  553. (scheme #xaf33)
  554. (emacs-lisp #xaf34)
  555. (ecmascript #xaf35)
  556. (lua #xaf36)
  557. (brainfuck #xaf37)
  558. (hi-user #xffff))
  559. ;; Figure 29: Case sensitivity.
  560. ;;
  561. (define-enumeration case-sensitivity-code->name case-sensitivity-name->code
  562. (case-sensitive 0)
  563. (up-case 1)
  564. (down-case 2)
  565. (case-insensitive 3))
  566. ;; Figure 30: Calling convention.
  567. ;;
  568. (define-enumeration calling-convention-code->name calling-convention-name->code
  569. (normal #x1)
  570. (program #x2)
  571. (nocall #x3)
  572. (lo-user #x40)
  573. (hi-user #xff))
  574. ;; Figure 31: Inline attribute.
  575. ;;
  576. (define-enumeration inline-code->name inline-name->code
  577. (not-inlined 0)
  578. (inlined 1)
  579. (declared-not-inlined 2)
  580. (declared-inlined 3))
  581. ;; Figure 32: Array ordering names and codes.
  582. (define-enumeration ordering-code->name ordering-name->code
  583. (row-major 0)
  584. (col-major 1))
  585. ;; Figure 33: Discriminant lists.
  586. ;;
  587. (define-enumeration discriminant-code->name discriminant-name->code
  588. (label 0)
  589. (range 1))
  590. ;; Figure 34: "Standard" line number opcodes.
  591. ;;
  592. (define-enumeration standard-line-opcode->name standard-line-name->opcode
  593. (extended-op 0)
  594. (copy 1)
  595. (advance-pc 2)
  596. (advance-line 3)
  597. (set-file 4)
  598. (set-column 5)
  599. (negate-stmt 6)
  600. (set-basic-block 7)
  601. (const-add-pc 8)
  602. (fixed-advance-pc 9)
  603. ;; DWARF 3.
  604. (set-prologue-end #x0a)
  605. (set-epilogue-begin #x0b)
  606. (set-isa #x0c))
  607. ;; Figure 35: "Extended" line number opcodes.
  608. ;;
  609. (define-enumeration extended-line-opcode->name extended-line-name->opcode
  610. (end-sequence 1)
  611. (set-address 2)
  612. (define-file 3)
  613. ;; DWARF 3.
  614. (lo-user #x80)
  615. (hi-user #xff))
  616. ;; Figure 36: Names and codes for macro information.
  617. ;;
  618. (define-enumeration macro-code->name macro-name->code
  619. (define 1)
  620. (undef 2)
  621. (start-file 3)
  622. (end-file 4)
  623. (vendor-ext 255))
  624. ;; Figure 37: Call frame information.
  625. ;;
  626. (define-enumeration call-frame-address-code->name call-frame-address-code->name
  627. (advance-loc #x40)
  628. (offset #x80)
  629. (restore #xc0)
  630. (nop #x00)
  631. (set-loc #x01)
  632. (advance-loc1 #x02)
  633. (advance-loc2 #x03)
  634. (advance-loc4 #x04)
  635. (offset-extended #x05)
  636. (restore-extended #x06)
  637. (undefined #x07)
  638. (same-value #x08)
  639. (register #x09)
  640. (remember-state #x0a)
  641. (restore-state #x0b)
  642. (def-cfa #x0c)
  643. (def-cfa-register #x0d)
  644. (def-cfa-offset #x0e)
  645. ;; DWARF 3.
  646. (def-cfa-expression #x0f)
  647. (expression #x10)
  648. (offset-extended-sf #x11)
  649. (def-cfa-sf #x12)
  650. (def-cfa-offset-sf #x13)
  651. (val-offset #x14)
  652. (val-offset-sf #x15)
  653. (val-expression #x16)
  654. (GNU-window-save #x2d)
  655. (GNU-args-size #x2e)
  656. (GNU-negative-offset-extended #x2f)
  657. (extended 0)
  658. (low-user #x1c)
  659. (high-user #x3f))
  660. ;(define CIE-ID #xffffffff)
  661. ;(define CIE-VERSION 1)
  662. ;(define ADDR-none 0)
  663. ;;;
  664. ;;; A general configuration object.
  665. ;;;
  666. (define-record-type <dwarf-meta>
  667. (make-dwarf-meta addr-size
  668. vaddr memsz
  669. path lib-path
  670. info-start info-end
  671. abbrevs-start abbrevs-end
  672. strtab-start strtab-end
  673. loc-start loc-end
  674. line-start line-end
  675. pubnames-start pubnames-end
  676. aranges-start aranges-end)
  677. dwarf-meta?
  678. (addr-size meta-addr-size)
  679. (vaddr meta-vaddr)
  680. (memsz meta-memsz)
  681. (path meta-path)
  682. (lib-path meta-lib-path)
  683. (info-start meta-info-start)
  684. (info-end meta-info-end)
  685. (abbrevs-start meta-abbrevs-start)
  686. (abbrevs-end meta-abbrevs-end)
  687. (strtab-start meta-strtab-start)
  688. (strtab-end meta-strtab-end)
  689. (loc-start meta-loc-start)
  690. (loc-end meta-loc-end)
  691. (line-start meta-line-start)
  692. (line-end meta-line-end)
  693. (pubnames-start meta-pubnames-start)
  694. (pubnames-end meta-pubnames-end)
  695. (aranges-start meta-aranges-start)
  696. (aranges-end meta-aranges-end))
  697. ;; A context represents a namespace. The root context is the
  698. ;; compilation unit. DIE nodes of type class-type, structure-type, or
  699. ;; namespace may form child contexts.
  700. ;;
  701. (define-record-type <dwarf-context>
  702. (make-dwarf-context bv offset-size endianness meta
  703. abbrevs
  704. parent die start end children)
  705. dwarf-context?
  706. (bv ctx-bv)
  707. (offset-size ctx-offset-size)
  708. (endianness ctx-endianness)
  709. (meta ctx-meta)
  710. (abbrevs ctx-abbrevs)
  711. (parent ctx-parent)
  712. (die ctx-die)
  713. (start ctx-start)
  714. (end ctx-end)
  715. (children ctx-children set-children!))
  716. (set-record-type-printer! <dwarf-context>
  717. (lambda (x port)
  718. (format port "<dwarf-context ~a>"
  719. (number->string (object-address x) 16))))
  720. (define-inlinable (ctx-addr-size ctx)
  721. (meta-addr-size (ctx-meta ctx)))
  722. ;;;
  723. ;;; Procedures for reading DWARF data.
  724. ;;;
  725. (define (read-u8 ctx pos)
  726. (values (bytevector-u8-ref (ctx-bv ctx) pos)
  727. (1+ pos)))
  728. (define (read-s8 ctx pos)
  729. (values (bytevector-s8-ref (ctx-bv ctx) pos)
  730. (1+ pos)))
  731. (define (skip-8 ctx pos)
  732. (+ pos 1))
  733. (define (read-u16 ctx pos)
  734. (values (bytevector-u16-ref (ctx-bv ctx) pos (ctx-endianness ctx))
  735. (+ pos 2)))
  736. (define (skip-16 ctx pos)
  737. (+ pos 2))
  738. (define (read-u32 ctx pos)
  739. (values (bytevector-u32-ref (ctx-bv ctx) pos (ctx-endianness ctx))
  740. (+ pos 4)))
  741. (define (skip-32 ctx pos)
  742. (+ pos 4))
  743. (define (read-u64 ctx pos)
  744. (values (bytevector-u64-ref (ctx-bv ctx) pos (ctx-endianness ctx))
  745. (+ pos 8)))
  746. (define (skip-64 ctx pos)
  747. (+ pos 8))
  748. (define (read-addr ctx pos)
  749. (case (ctx-addr-size ctx)
  750. ((4) (read-u32 ctx pos))
  751. ((8) (read-u64 ctx pos))
  752. (else (error "unsupported word size" ctx))))
  753. (define (skip-addr ctx pos)
  754. (+ pos (ctx-addr-size ctx)))
  755. (define (%read-uleb128 bv pos)
  756. ;; Unrolled by one.
  757. (let ((b (bytevector-u8-ref bv pos)))
  758. (if (zero? (logand b #x80))
  759. (values b
  760. (1+ pos))
  761. (let lp ((n (logxor #x80 b)) (pos (1+ pos)) (shift 7))
  762. (let ((b (bytevector-u8-ref bv pos)))
  763. (if (zero? (logand b #x80))
  764. (values (logior (ash b shift) n)
  765. (1+ pos))
  766. (lp (logior (ash (logxor #x80 b) shift) n)
  767. (1+ pos)
  768. (+ shift 7))))))))
  769. (define (%read-sleb128 bv pos)
  770. (let lp ((n 0) (pos pos) (shift 0))
  771. (let ((b (bytevector-u8-ref bv pos)))
  772. (if (zero? (logand b #x80))
  773. (values (logior (ash b shift) n
  774. (if (zero? (logand #x40 b))
  775. 0
  776. (- (ash 1 (+ shift 7)))))
  777. (1+ pos))
  778. (lp (logior (ash (logxor #x80 b) shift) n)
  779. (1+ pos)
  780. (+ shift 7))))))
  781. (define (read-uleb128 ctx pos)
  782. (%read-uleb128 (ctx-bv ctx) pos))
  783. (define (read-sleb128 ctx pos)
  784. (%read-sleb128 (ctx-bv ctx) pos))
  785. (define (skip-leb128 ctx pos)
  786. (let ((bv (ctx-bv ctx)))
  787. (let lp ((pos pos))
  788. (let ((b (bytevector-u8-ref bv pos)))
  789. (if (zero? (logand b #x80))
  790. (1+ pos)
  791. (lp (1+ pos)))))))
  792. (define (read-initial-length ctx pos)
  793. (let ((len (bytevector-u32-ref (ctx-bv ctx) pos (ctx-endianness ctx))))
  794. (cond
  795. ((= len #xffffffff)
  796. (values (bytevector-u32-ref (ctx-bv ctx) (+ pos 4) (ctx-endianness ctx))
  797. (+ pos 12)
  798. 8))
  799. ((>= len #xfffffff0)
  800. (error "bad initial length value" len))
  801. (else
  802. (values len
  803. (+ pos 4)
  804. 4)))))
  805. (define* (read-offset ctx pos #:optional (offset-size (ctx-offset-size ctx)))
  806. (case offset-size
  807. ((4) (values (read-u32 ctx pos) (+ pos 4)))
  808. ((8) (values (read-u64 ctx pos) (+ pos 8)))
  809. (else (error "bad word size" offset-size))))
  810. (define* (skip-offset ctx pos #:optional (offset-size (ctx-offset-size ctx)))
  811. (+ pos offset-size))
  812. (define (read-block ctx pos len)
  813. (let ((bv (make-bytevector len)))
  814. (bytevector-copy! (ctx-bv ctx) pos bv 0 len)
  815. (values bv
  816. (+ pos len))))
  817. (define (read-string ctx pos)
  818. (let ((bv (ctx-bv ctx)))
  819. (let lp ((end pos))
  820. (if (zero? (bytevector-u8-ref bv end))
  821. (let ((out (make-bytevector (- end pos))))
  822. (bytevector-copy! bv pos out 0 (- end pos))
  823. (values (utf8->string out)
  824. (1+ end)))
  825. (lp (1+ end))))))
  826. (define (skip-string ctx pos)
  827. (let ((bv (ctx-bv ctx)))
  828. (let lp ((end pos))
  829. (if (zero? (bytevector-u8-ref bv end))
  830. (1+ end)
  831. (lp (1+ end))))))
  832. (define (read-string-seq ctx pos)
  833. (let ((bv (ctx-bv ctx)))
  834. (let lp ((pos pos) (strs '()))
  835. (if (zero? (bytevector-u8-ref bv pos))
  836. (values (list->vector (reverse strs)) (1+ pos))
  837. (let-values (((str pos) (read-string ctx pos)))
  838. (lp pos (cons str strs)))))))
  839. (define-record-type <abbrev>
  840. (make-abbrev code tag has-children? attrs forms)
  841. abbrev?
  842. (code abbrev-code)
  843. (tag abbrev-tag)
  844. (has-children? abbrev-has-children?)
  845. (attrs abbrev-attrs)
  846. (forms abbrev-forms))
  847. (define (read-abbrev ctx pos)
  848. (let*-values (((code pos) (read-uleb128 ctx pos))
  849. ((tag pos) (read-uleb128 ctx pos))
  850. ((children pos) (read-u8 ctx pos)))
  851. (let lp ((attrs '()) (forms '()) (pos pos))
  852. (let*-values (((attr pos) (read-uleb128 ctx pos))
  853. ((form pos) (read-uleb128 ctx pos)))
  854. (if (and (zero? attr) (zero? form))
  855. (values (make-abbrev code
  856. (tag-code->name tag)
  857. (eq? (children-code->name children) 'yes)
  858. (reverse attrs)
  859. (reverse forms))
  860. pos)
  861. (lp (cons (attribute-code->name attr) attrs)
  862. (cons (form-code->name form) forms)
  863. pos))))))
  864. (define* (read-abbrevs ctx pos
  865. #:optional (start (meta-abbrevs-start
  866. (ctx-meta ctx)))
  867. (end (meta-abbrevs-end
  868. (ctx-meta ctx))))
  869. (let lp ((abbrevs '()) (pos (+ start pos)) (max-code -1))
  870. (if (zero? (read-u8 ctx pos))
  871. (if (< pos end)
  872. (let ((av (make-vector (1+ max-code) #f)))
  873. (for-each (lambda (a)
  874. (vector-set! av (abbrev-code a) a))
  875. abbrevs)
  876. av)
  877. (error "Unexpected length" abbrevs pos start end))
  878. (let-values (((abbrev pos) (read-abbrev ctx pos)))
  879. (lp (cons abbrev abbrevs)
  880. pos
  881. (max (abbrev-code abbrev) max-code))))))
  882. (define (ctx-compile-unit-start ctx)
  883. (if (ctx-die ctx)
  884. (ctx-compile-unit-start (ctx-parent ctx))
  885. (ctx-start ctx)))
  886. ;; Values.
  887. ;;
  888. (define *readers* (make-hash-table))
  889. (define *scanners* (make-hash-table))
  890. (define-syntax define-value-reader
  891. (syntax-rules ()
  892. ((_ form reader scanner)
  893. (begin
  894. (hashq-set! *readers* 'form reader)
  895. (hashq-set! *scanners* 'form scanner)))))
  896. (define-value-reader addr read-addr skip-addr)
  897. (define-value-reader block
  898. (lambda (ctx pos)
  899. (let-values (((len pos) (read-uleb128 ctx pos)))
  900. (read-block ctx pos len)))
  901. (lambda (ctx pos)
  902. (let-values (((len pos) (read-uleb128 ctx pos)))
  903. (+ pos len))))
  904. (define-value-reader block1
  905. (lambda (ctx pos)
  906. (let-values (((len pos) (read-u8 ctx pos)))
  907. (read-block ctx pos len)))
  908. (lambda (ctx pos)
  909. (+ pos 1 (bytevector-u8-ref (ctx-bv ctx) pos))))
  910. (define-value-reader block2
  911. (lambda (ctx pos)
  912. (let-values (((len pos) (read-u16 ctx pos)))
  913. (read-block ctx pos len)))
  914. (lambda (ctx pos)
  915. (+ pos 2 (bytevector-u16-ref (ctx-bv ctx) pos (ctx-endianness ctx)))))
  916. (define-value-reader block4
  917. (lambda (ctx pos)
  918. (let-values (((len pos) (read-u32 ctx pos)))
  919. (read-block ctx pos len)))
  920. (lambda (ctx pos)
  921. (+ pos 4 (bytevector-u32-ref (ctx-bv ctx) pos (ctx-endianness ctx)))))
  922. (define-value-reader data1 read-u8 skip-8)
  923. (define-value-reader data2 read-u16 skip-16)
  924. (define-value-reader data4 read-u32 skip-32)
  925. (define-value-reader data8 read-u64 skip-64)
  926. (define-value-reader udata read-uleb128 skip-leb128)
  927. (define-value-reader sdata read-sleb128 skip-leb128)
  928. (define-value-reader flag
  929. (lambda (ctx pos)
  930. (values (not (zero? (bytevector-u8-ref (ctx-bv ctx) pos)))
  931. (1+ pos)))
  932. skip-8)
  933. (define-value-reader string
  934. read-string
  935. skip-string)
  936. (define-value-reader strp
  937. (lambda (ctx pos)
  938. (let ((strtab (meta-strtab-start (ctx-meta ctx))))
  939. (unless strtab
  940. (error "expected a string table" ctx))
  941. (let-values (((offset pos) (read-offset ctx pos)))
  942. (values (read-string ctx (+ strtab offset))
  943. pos))))
  944. skip-32)
  945. (define-value-reader ref-addr
  946. (lambda (ctx pos)
  947. (let-values (((addr pos) (read-addr ctx pos)))
  948. (values (+ addr (meta-info-start (ctx-meta ctx)))
  949. pos)))
  950. skip-addr)
  951. (define-value-reader ref1
  952. (lambda (ctx pos)
  953. (let-values (((addr pos) (read-u8 ctx pos)))
  954. (values (+ addr (ctx-compile-unit-start ctx))
  955. pos)))
  956. skip-8)
  957. (define-value-reader ref2
  958. (lambda (ctx pos)
  959. (let-values (((addr pos) (read-u16 ctx pos)))
  960. (values (+ addr (ctx-compile-unit-start ctx))
  961. pos)))
  962. skip-16)
  963. (define-value-reader ref4
  964. (lambda (ctx pos)
  965. (let-values (((addr pos) (read-u32 ctx pos)))
  966. (values (+ addr (ctx-compile-unit-start ctx))
  967. pos)))
  968. skip-32)
  969. (define-value-reader ref8
  970. (lambda (ctx pos)
  971. (let-values (((addr pos) (read-u64 ctx pos)))
  972. (values (+ addr (ctx-compile-unit-start ctx))
  973. pos)))
  974. skip-64)
  975. (define-value-reader ref
  976. (lambda (udata ctx pos)
  977. (let-values (((addr pos) (read-uleb128 ctx pos)))
  978. (values (+ addr (ctx-compile-unit-start ctx))
  979. pos)))
  980. skip-leb128)
  981. (define-value-reader indirect
  982. (lambda (ctx pos)
  983. (let*-values (((form pos) (read-uleb128 ctx pos))
  984. ((val pos) (read-value ctx pos (form-code->name form))))
  985. (values (cons form val)
  986. pos)))
  987. (lambda (ctx pos)
  988. (let*-values (((form pos) (read-uleb128 ctx pos)))
  989. (skip-value ctx pos (form-code->name form)))))
  990. (define-value-reader sec-offset
  991. read-offset
  992. skip-offset)
  993. (define-value-reader exprloc
  994. (lambda (ctx pos)
  995. (let-values (((len pos) (read-uleb128 ctx pos)))
  996. (read-block ctx pos len)))
  997. (lambda (ctx pos)
  998. (let-values (((len pos) (read-uleb128 ctx pos)))
  999. (+ pos len))))
  1000. (define-value-reader flag-present
  1001. (lambda (ctx pos)
  1002. (values #t pos))
  1003. (lambda (ctx pos)
  1004. pos))
  1005. (define-value-reader ref-sig8
  1006. read-u64
  1007. skip-64)
  1008. (define (read-value ctx pos form)
  1009. ((or (hashq-ref *readers* form)
  1010. (error "unrecognized form" form))
  1011. ctx pos))
  1012. (define (skip-value ctx pos form)
  1013. ((or (hashq-ref *scanners* form)
  1014. (error "unrecognized form" form))
  1015. ctx pos))
  1016. ;; Parsers for particular attributes.
  1017. ;;
  1018. (define (parse-location-list ctx offset)
  1019. (let lp ((pos (+ (meta-loc-start (ctx-meta ctx)) offset))
  1020. (out '()))
  1021. (let*-values (((start pos) (read-addr ctx pos))
  1022. ((end pos) (read-addr ctx pos)))
  1023. (if (and (zero? start) (zero? end))
  1024. (reverse out)
  1025. (let*-values (((len pos) (read-u16 ctx pos))
  1026. ((block pos) (read-block ctx pos len)))
  1027. (lp pos
  1028. (cons (list start end (parse-location ctx block)) out)))))))
  1029. (define (parse-location ctx loc)
  1030. (cond
  1031. ((bytevector? loc)
  1032. (let ((len (bytevector-length loc))
  1033. (addr-size (ctx-addr-size ctx))
  1034. (endianness (ctx-endianness ctx)))
  1035. (define (u8-ref pos) (bytevector-u8-ref loc pos))
  1036. (define (s8-ref pos) (bytevector-s8-ref loc pos))
  1037. (define (u16-ref pos) (bytevector-u16-ref loc pos endianness))
  1038. (define (s16-ref pos) (bytevector-s16-ref loc pos endianness))
  1039. (define (u32-ref pos) (bytevector-u32-ref loc pos endianness))
  1040. (define (s32-ref pos) (bytevector-s32-ref loc pos endianness))
  1041. (define (u64-ref pos) (bytevector-u64-ref loc pos endianness))
  1042. (define (s64-ref pos) (bytevector-s64-ref loc pos endianness))
  1043. (let lp ((pos 0) (out '()))
  1044. (if (= pos len)
  1045. (reverse out)
  1046. (let ((op (location-op->name (u8-ref pos))))
  1047. (case op
  1048. ((addr)
  1049. (case addr-size
  1050. ((4) (lp (+ pos 5) (cons (list op (u32-ref (1+ pos))) out)))
  1051. ((8) (lp (+ pos 9) (cons (list op (u64-ref (1+ pos))) out)))
  1052. (else (error "what!"))))
  1053. ((call-ref)
  1054. (case addr-size
  1055. ((4) (lp (+ pos 5)
  1056. (cons (list op (+ (meta-info-start (ctx-meta ctx))
  1057. (u32-ref (1+ pos))))
  1058. out)))
  1059. ((8) (lp (+ pos 9)
  1060. (cons (list op (+ (meta-info-start (ctx-meta ctx))
  1061. (u64-ref (1+ pos))))
  1062. out)))
  1063. (else (error "what!"))))
  1064. ((const1u pick deref-size xderef-size)
  1065. (lp (+ pos 2) (cons (list op (u8-ref (1+ pos))) out)))
  1066. ((const1s)
  1067. (lp (+ pos 2) (cons (list op (s8-ref (1+ pos))) out)))
  1068. ((const2u)
  1069. (lp (+ pos 3) (cons (list op (u16-ref (1+ pos))) out)))
  1070. ((call2)
  1071. (lp (+ pos 3) (cons (list op (+ (ctx-compile-unit-start ctx)
  1072. (u16-ref (1+ pos))))
  1073. out)))
  1074. ((const2s skip bra)
  1075. (lp (+ pos 3) (cons (list op (s16-ref (1+ pos))) out)))
  1076. ((const4u)
  1077. (lp (+ pos 5) (cons (list op (u32-ref (1+ pos))) out)))
  1078. ((call4)
  1079. (lp (+ pos 5) (cons (list op (+ (ctx-compile-unit-start ctx)
  1080. (u32-ref (1+ pos))))
  1081. out)))
  1082. ((const4s)
  1083. (lp (+ pos 5) (cons (list op (s32-ref (1+ pos))) out)))
  1084. ((const8u)
  1085. (lp (+ pos 9) (cons (list op (u64-ref (1+ pos))) out)))
  1086. ((const8s)
  1087. (lp (+ pos 9) (cons (list op (s64-ref (1+ pos))) out)))
  1088. ((plus-uconst regx piece)
  1089. (let-values (((val pos) (%read-uleb128 loc (1+ pos))))
  1090. (lp pos (cons (list op val) out))))
  1091. ((bit-piece)
  1092. (let*-values (((bit-len pos) (%read-uleb128 loc (1+ pos)))
  1093. ((bit-offset pos) (%read-uleb128 loc pos)))
  1094. (lp pos (cons (list op bit-len bit-offset) out))))
  1095. ((breg0 breg1 breg2 breg3 breg4 breg5 breg6 breg7 breg8 breg9
  1096. breg10 breg11 breg12 breg13 breg14 breg15 breg16 breg17
  1097. breg18 breg19 breg20 breg21 breg22 breg23 breg24 breg25
  1098. breg26 breg27 breg28 breg29 breg30 breg31 fbreg)
  1099. (let-values (((val pos) (%read-sleb128 loc (1+ pos))))
  1100. (lp pos (cons (list op val) out))))
  1101. (else
  1102. (if (number? op)
  1103. ;; We failed to parse this opcode; we have to give
  1104. ;; up
  1105. loc
  1106. (lp (1+ pos) (cons (list op) out))))))))))
  1107. (else
  1108. (parse-location-list ctx loc))))
  1109. ;; Statement programs.
  1110. (define-record-type <lregs>
  1111. (make-lregs pos pc file line column)
  1112. lregs?
  1113. (pos lregs-pos set-lregs-pos!)
  1114. (pc lregs-pc set-lregs-pc!)
  1115. (file lregs-file set-lregs-file!)
  1116. (line lregs-line set-lregs-line!)
  1117. (column lregs-column set-lregs-column!))
  1118. (define-record-type <line-prog>
  1119. (%make-line-prog ctx version
  1120. header-offset program-offset end
  1121. min-insn-length max-insn-ops default-stmt?
  1122. line-base line-range opcode-base
  1123. standard-opcode-lengths
  1124. include-directories file-names
  1125. regs)
  1126. line-prog?
  1127. (ctx line-prog-ctx)
  1128. (version line-prog-version)
  1129. (header-offset line-prog-header-offset)
  1130. (program-offset line-prog-program-offset)
  1131. (end line-prog-end)
  1132. (min-insn-length line-prog-min-insn-length)
  1133. (max-insn-ops line-prog-max-insn-ops)
  1134. (default-stmt? line-prog-default-stmt?)
  1135. (line-base line-prog-line-base)
  1136. (line-range line-prog-line-range)
  1137. (opcode-base line-prog-opcode-base)
  1138. (standard-opcode-lengths line-prog-standard-opcode-lengths)
  1139. (include-directories line-prog-include-directories)
  1140. (file-names line-prog-file-names)
  1141. (regs line-prog-regs))
  1142. (define (make-line-prog ctx header-pos end)
  1143. (unless (> end (+ header-pos 12))
  1144. (error "statement program header too short"))
  1145. (let-values (((len pos offset-size) (read-initial-length ctx header-pos)))
  1146. (unless (<= (+ pos len) end)
  1147. (error (".debug_line too short")))
  1148. (let*-values (((version pos) (read-u16 ctx pos))
  1149. ((prologue-len prologue-pos) (read-u32 ctx pos))
  1150. ((min-insn-len pos) (read-u8 ctx prologue-pos))
  1151. ;; The maximum_operations_per_instruction field is
  1152. ;; only present in DWARFv4.
  1153. ((max-insn-ops pos) (if (< version 4)
  1154. (values 1 pos)
  1155. (read-u8 ctx pos)))
  1156. ((default-stmt pos) (read-u8 ctx pos))
  1157. ((line-base pos) (read-s8 ctx pos))
  1158. ((line-range pos) (read-u8 ctx pos))
  1159. ((opcode-base pos) (read-u8 ctx pos))
  1160. ((opcode-lens pos) (read-block ctx pos (1- opcode-base)))
  1161. ((include-directories pos) (read-string-seq ctx pos))
  1162. ((file-names pos)
  1163. (let lp ((pos pos) (strs '()))
  1164. (if (zero? (bytevector-u8-ref (ctx-bv ctx) pos))
  1165. (values (reverse strs) (1+ pos))
  1166. (let-values (((str pos) (read-string ctx pos)))
  1167. (let* ((pos (skip-leb128 ctx pos)) ; skip dir
  1168. (pos (skip-leb128 ctx pos)) ; skip mtime
  1169. (pos (skip-leb128 ctx pos))) ; skip len
  1170. (lp pos (cons str strs))))))))
  1171. (unless (= pos (+ prologue-pos prologue-len))
  1172. (error "unexpected prologue length"))
  1173. (%make-line-prog ctx version header-pos pos end
  1174. min-insn-len max-insn-ops (not (zero? default-stmt))
  1175. line-base line-range opcode-base opcode-lens
  1176. include-directories file-names
  1177. ;; Initial state: file=1, line=1, col=0
  1178. (make-lregs pos 0 1 1 0)))))
  1179. (define (line-prog-next-row prog pos pc file line col)
  1180. (let ((ctx (line-prog-ctx prog))
  1181. (end (line-prog-end prog))
  1182. (min-insn-len (line-prog-min-insn-length prog))
  1183. (line-base (line-prog-line-base prog))
  1184. (line-range (line-prog-line-range prog))
  1185. (opcode-base (line-prog-opcode-base prog))
  1186. (opcode-lens (line-prog-standard-opcode-lengths prog)))
  1187. (let lp ((pos pos) (pc pc) (file file) (line line) (col col))
  1188. (cond
  1189. ((>= pos end)
  1190. (values #f #f #f #f #f))
  1191. (else
  1192. (let-values (((op pos) (read-u8 ctx pos)))
  1193. (cond
  1194. ((zero? op) ; extended opcodes
  1195. (let*-values (((len pos*) (read-uleb128 ctx pos))
  1196. ((op pos) (read-u8 ctx pos*)))
  1197. (case op
  1198. ((1) ; end-sequence
  1199. (values pos pc file line col))
  1200. ((2) ; set-address
  1201. (let-values (((addr pos) (read-addr ctx pos)))
  1202. (unless (>= addr pc)
  1203. (error "pc not advancing"))
  1204. (lp pos addr file line col)))
  1205. ((3) ; define-file
  1206. (warn "define-file unimplemented")
  1207. (lp (+ pos* len) pc file line col))
  1208. ((4) ; set-discriminator; ignore.
  1209. (lp (+ pos* len) pc file line col))
  1210. (else
  1211. (warn "unknown extended op" op)
  1212. (lp (+ pos* len) pc file line col)))))
  1213. ((< op opcode-base) ; standard opcodes
  1214. (case op
  1215. ((1) ; copy
  1216. (values pos pc file line col))
  1217. ((2) ; advance-pc
  1218. (let-values (((advance pos) (read-uleb128 ctx pos)))
  1219. (lp pos (+ pc (* advance min-insn-len)) file line col)))
  1220. ((3) ; advance-line
  1221. (let-values (((diff pos) (read-sleb128 ctx pos)))
  1222. (lp pos pc file (+ line diff) col)))
  1223. ((4) ; set-file
  1224. (let-values (((file pos) (read-uleb128 ctx pos)))
  1225. (lp pos pc file line col)))
  1226. ((5) ; set-column
  1227. (let-values (((col pos) (read-uleb128 ctx pos)))
  1228. (lp pos pc file line col)))
  1229. ((6) ; negate-line
  1230. (lp pos pc file line col))
  1231. ((7) ; set-basic-block
  1232. (lp pos pc file line col))
  1233. ((8) ; const-add-pc
  1234. (let ((advance (floor/ (- 255 opcode-base) line-range)))
  1235. (lp pos (+ pc (* advance min-insn-len)) file line col)))
  1236. ((9) ; fixed-advance-pc
  1237. (let-values (((advance pos) (read-u16 ctx pos)))
  1238. (lp pos (+ pc (* advance min-insn-len)) file line col)))
  1239. (else
  1240. ;; fixme: read args and move on
  1241. (error "unknown extended op" op))))
  1242. (else ; special opcodes
  1243. (let-values (((quo rem) (floor/ (- op opcode-base) line-range)))
  1244. (values pos (+ pc (* quo min-insn-len))
  1245. file (+ line (+ rem line-base)) col))))))))))
  1246. (define (line-prog-advance prog)
  1247. (let ((regs (line-prog-regs prog)))
  1248. (call-with-values (lambda ()
  1249. (line-prog-next-row prog
  1250. (lregs-pos regs)
  1251. (lregs-pc regs)
  1252. (lregs-file regs)
  1253. (lregs-line regs)
  1254. (lregs-column regs)))
  1255. (lambda (pos pc file line col)
  1256. (cond
  1257. ((not pos)
  1258. (values #f #f #f #f))
  1259. (else
  1260. (set-lregs-pos! regs pos)
  1261. (set-lregs-pc! regs pc)
  1262. (set-lregs-file! regs file)
  1263. (set-lregs-line! regs line)
  1264. (set-lregs-column! regs col)
  1265. ;; Return DWARF-numbered lines and columns (1-based).
  1266. (values pc
  1267. (if (zero? file)
  1268. #f
  1269. (list-ref (line-prog-file-names prog) (1- file)))
  1270. (if (zero? line) #f line)
  1271. (if (zero? col) #f col))))))))
  1272. (define (line-prog-scan-to-pc prog target-pc)
  1273. (let ((regs (line-prog-regs prog)))
  1274. (define (finish pos pc file line col)
  1275. (set-lregs-pos! regs pos)
  1276. (set-lregs-pc! regs pc)
  1277. (set-lregs-file! regs file)
  1278. (set-lregs-line! regs line)
  1279. (set-lregs-column! regs col)
  1280. ;; Return DWARF-numbered lines and columns (1-based).
  1281. (values pc
  1282. (if (zero? file)
  1283. #f
  1284. (list-ref (line-prog-file-names prog) (1- file)))
  1285. (if (zero? line) #f line)
  1286. (if (zero? col) #f col)))
  1287. (define (scan pos pc file line col)
  1288. (call-with-values (lambda ()
  1289. (line-prog-next-row prog pos pc file line col))
  1290. (lambda (pos* pc* file* line* col*)
  1291. (cond
  1292. ((not pos*)
  1293. (values #f #f #f #f))
  1294. ((< pc* target-pc)
  1295. (scan pos* pc* file* line* col*))
  1296. ((= pc* target-pc)
  1297. (finish pos* pc* file* line* col*))
  1298. ((zero? pc)
  1299. ;; We scanned from the beginning didn't find any info.
  1300. (values #f #f #f #f))
  1301. (else
  1302. (finish pos pc file line col))))))
  1303. (let ((pos (lregs-pos regs))
  1304. (pc (lregs-pc regs))
  1305. (file (lregs-file regs))
  1306. (line (lregs-line regs))
  1307. (col (lregs-column regs)))
  1308. (if (< pc target-pc)
  1309. (scan pos pc file line col)
  1310. (scan (line-prog-program-offset prog) 0 1 1 0)))))
  1311. (define-syntax-rule (define-attribute-parsers parse (name parser) ...)
  1312. (define parse
  1313. (let ((parsers (make-hash-table)))
  1314. (hashq-set! parsers 'name parser)
  1315. ...
  1316. (lambda (ctx attr val)
  1317. (cond
  1318. ((hashq-ref parsers attr) => (lambda (p) (p ctx val)))
  1319. (else val))))))
  1320. (define-attribute-parsers parse-attribute
  1321. (encoding (lambda (ctx val) (type-encoding->name val)))
  1322. (accessibility (lambda (ctx val) (access-code->name val)))
  1323. (visibility (lambda (ctx val) (visibility-code->name val)))
  1324. (virtuality (lambda (ctx val) (virtuality-code->name val)))
  1325. (language (lambda (ctx val) (language-code->name val)))
  1326. (location parse-location)
  1327. (data-member-location parse-location)
  1328. (case-sensitive (lambda (ctx val) (case-sensitivity-code->name val)))
  1329. (calling-convention (lambda (ctx val) (calling-convention-code->name val)))
  1330. (inline (lambda (ctx val) (inline-code->name val)))
  1331. (ordering (lambda (ctx val) (ordering-code->name val)))
  1332. (discr-value (lambda (ctx val) (discriminant-code->name val))))
  1333. ;; "Debugging Information Entries": DIEs.
  1334. ;;
  1335. (define-record-type <die>
  1336. (make-die ctx offset abbrev vals)
  1337. die?
  1338. (ctx die-ctx)
  1339. (offset die-offset)
  1340. (abbrev die-abbrev)
  1341. (vals %die-vals %set-die-vals!))
  1342. (define (die-tag die)
  1343. (abbrev-tag (die-abbrev die)))
  1344. (define (die-attrs die)
  1345. (abbrev-attrs (die-abbrev die)))
  1346. (define (die-forms die)
  1347. (abbrev-forms (die-abbrev die)))
  1348. (define (die-vals die)
  1349. (let ((vals (%die-vals die)))
  1350. (or vals
  1351. (begin
  1352. (%set-die-vals! die (read-values (die-ctx die) (skip-leb128 (die-ctx die) (die-offset die)) (die-abbrev die)))
  1353. (die-vals die)))))
  1354. (define* (die-next-offset die #:optional offset-vals)
  1355. (let ((ctx (die-ctx die)))
  1356. (skip-values ctx (or offset-vals (skip-leb128 ctx (die-offset die)))
  1357. (die-abbrev die))))
  1358. (define* (die-ref die attr #:optional default)
  1359. (cond
  1360. ((list-index (die-attrs die) attr)
  1361. => (lambda (n) (list-ref (die-vals die) n)))
  1362. (else default)))
  1363. (define (die-specification die)
  1364. (and=> (die-ref die 'specification)
  1365. (lambda (offset) (find-die-by-offset (die-ctx die) offset))))
  1366. (define (die-name die)
  1367. (or (die-ref die 'name)
  1368. (and=> (die-specification die) die-name)))
  1369. (define (die-qname die)
  1370. (cond
  1371. ((eq? (die-tag die) 'compile-unit) "")
  1372. ((die-ref die 'name)
  1373. => (lambda (name)
  1374. (if (eq? (die-tag (ctx-die (die-ctx die))) 'compile-unit)
  1375. name ; short cut
  1376. (string-append (die-qname (ctx-die (die-ctx die))) "::" name))))
  1377. ((die-specification die)
  1378. => die-qname)
  1379. (else #f)))
  1380. (define (die-line-prog die)
  1381. (let ((stmt-list (die-ref die 'stmt-list)))
  1382. (and stmt-list
  1383. (let* ((ctx (die-ctx die))
  1384. (meta (ctx-meta ctx)))
  1385. (make-line-prog ctx
  1386. (+ (meta-line-start meta) stmt-list)
  1387. (meta-line-end meta))))))
  1388. (define (read-values ctx offset abbrev)
  1389. (let lp ((attrs (abbrev-attrs abbrev))
  1390. (forms (abbrev-forms abbrev))
  1391. (vals '())
  1392. (pos offset))
  1393. (if (null? forms)
  1394. (values (reverse vals) pos)
  1395. (let-values (((val pos) (read-value ctx pos (car forms))))
  1396. (lp (cdr attrs) (cdr forms)
  1397. (cons (parse-attribute ctx (car attrs) val) vals)
  1398. pos)))))
  1399. (define (skip-values ctx offset abbrev)
  1400. (let lp ((forms (abbrev-forms abbrev))
  1401. (pos offset))
  1402. (if (null? forms)
  1403. pos
  1404. (lp (cdr forms) (skip-value ctx pos (car forms))))))
  1405. (define (read-die-abbrev ctx offset)
  1406. (let*-values (((code pos) (read-uleb128 ctx offset)))
  1407. (values (cond ((zero? code) #f)
  1408. ((vector-ref (ctx-abbrevs ctx) code))
  1409. (else (error "unknown abbrev" ctx code)))
  1410. pos)))
  1411. (define (read-die ctx offset)
  1412. (let*-values (((abbrev pos) (read-die-abbrev ctx offset)))
  1413. (if abbrev
  1414. (values (make-die ctx offset abbrev #f)
  1415. (skip-values ctx pos abbrev))
  1416. (values #f pos))))
  1417. (define* (die-sibling ctx abbrev offset #:optional offset-vals offset-end)
  1418. (cond
  1419. ((not (abbrev-has-children? abbrev))
  1420. (or offset-end
  1421. (skip-values ctx
  1422. (or offset-vals (skip-leb128 ctx offset))
  1423. abbrev)))
  1424. ((memq 'sibling (abbrev-attrs abbrev))
  1425. (let lp ((offset (or offset-vals (skip-leb128 ctx offset)))
  1426. (attrs (abbrev-attrs abbrev))
  1427. (forms (abbrev-forms abbrev)))
  1428. (if (eq? (car attrs) 'sibling)
  1429. (read-value ctx offset (car forms))
  1430. (lp (skip-value ctx offset (car forms))
  1431. (cdr attrs) (cdr forms)))))
  1432. (else
  1433. (call-with-values
  1434. (lambda ()
  1435. (fold-die-list ctx
  1436. (or offset-end
  1437. (skip-values ctx
  1438. (or offset-vals
  1439. (skip-leb128 ctx offset))
  1440. abbrev))
  1441. (lambda (ctx offset abbrev) #t)
  1442. error
  1443. #f))
  1444. (lambda (seed pos)
  1445. pos)))))
  1446. (define (find-die-context ctx offset)
  1447. (define (not-found)
  1448. (error "failed to find DIE by context" offset))
  1449. (define (in-context? ctx)
  1450. (and (<= (ctx-start ctx) offset)
  1451. (< offset (ctx-end ctx))))
  1452. (define (find-root ctx)
  1453. (if (in-context? ctx)
  1454. ctx
  1455. (find-root (or (ctx-parent ctx) (not-found)))))
  1456. (define (find-leaf ctx)
  1457. (let lp ((kids (ctx-children ctx)))
  1458. (if (null? kids)
  1459. ctx
  1460. (if (in-context? (car kids))
  1461. (find-leaf (car kids))
  1462. (lp (cdr kids))))))
  1463. (find-leaf (find-root ctx)))
  1464. (define (find-die-by-offset ctx offset)
  1465. (or (read-die (find-die-context ctx offset) offset)
  1466. (error "Failed to read DIE at offset" offset)))
  1467. (define-syntax-rule (let/ec k e e* ...)
  1468. (let ((tag (make-prompt-tag)))
  1469. (call-with-prompt
  1470. tag
  1471. (lambda ()
  1472. (let ((k (lambda args (apply abort-to-prompt tag args))))
  1473. e e* ...))
  1474. (lambda (_ res) res))))
  1475. (define* (find-die roots pred #:key
  1476. (skip? (lambda (ctx offset abbrev) #f))
  1477. (recurse? (lambda (die) #t)))
  1478. (let/ec k
  1479. (define (visit-die die)
  1480. (cond
  1481. ((pred die)
  1482. (k die))
  1483. ((recurse? die)
  1484. (fold-die-children die (lambda (die seed) (visit-die die)) #f
  1485. #:skip? skip?))
  1486. (else #f)))
  1487. (for-each visit-die roots)
  1488. #f))
  1489. (define (die-low-pc die)
  1490. (die-ref die 'low-pc))
  1491. (define (die-high-pc die)
  1492. (let ((val (die-ref die 'high-pc)))
  1493. (and val
  1494. (let ((idx (list-index (die-attrs die) 'high-pc)))
  1495. (case (list-ref (die-forms die) idx)
  1496. ((addr) val)
  1497. (else (+ val (die-low-pc die))))))))
  1498. (define (find-die-by-pc roots pc)
  1499. ;; The result will be a subprogram.
  1500. (define (skip? ctx offset abbrev)
  1501. (case (abbrev-tag abbrev)
  1502. ((subprogram compile-unit) #f)
  1503. (else #t)))
  1504. (define (recurse? die)
  1505. (case (die-tag die)
  1506. ((compile-unit)
  1507. (not (or (and=> (die-low-pc die)
  1508. (lambda (low) (< pc low)))
  1509. (and=> (die-high-pc die)
  1510. (lambda (high) (<= high pc))))))
  1511. (else #f)))
  1512. (find-die roots
  1513. (lambda (die)
  1514. (and (eq? (die-tag die) 'subprogram)
  1515. (equal? (die-low-pc die) pc)))
  1516. #:skip? skip? #:recurse? recurse?))
  1517. (define (fold-die-list ctx offset skip? proc seed)
  1518. (let ((ctx (find-die-context ctx offset)))
  1519. (let lp ((offset offset) (seed seed))
  1520. (let-values (((abbrev pos) (read-die-abbrev ctx offset)))
  1521. (cond
  1522. ((not abbrev) (values seed pos))
  1523. ((skip? ctx offset abbrev)
  1524. (lp (die-sibling ctx abbrev offset pos) seed))
  1525. (else
  1526. (let-values (((vals pos) (read-values ctx pos abbrev)))
  1527. (let* ((die (make-die ctx offset abbrev vals))
  1528. (seed (proc die seed)))
  1529. (lp (die-sibling ctx abbrev offset #f pos) seed)))))))))
  1530. (define* (fold-die-children die proc seed #:key
  1531. (skip? (lambda (ctx offset abbrev) #f)))
  1532. (if (abbrev-has-children? (die-abbrev die))
  1533. (values (fold-die-list (die-ctx die) (die-next-offset die)
  1534. skip? proc seed))
  1535. seed))
  1536. (define (die-children die)
  1537. (reverse (fold-die-children die cons '())))
  1538. (define (add-to-parent! ctx)
  1539. (let ((parent (ctx-parent ctx)))
  1540. (set-children! parent
  1541. (append (ctx-children parent) (list ctx)))
  1542. ctx))
  1543. (define (make-compilation-unit-context ctx offset-size addr-size
  1544. abbrevs start len)
  1545. (unless (= addr-size (ctx-addr-size ctx))
  1546. (error "ELF word size not equal to compilation unit addrsize"))
  1547. (add-to-parent!
  1548. (make-dwarf-context (ctx-bv ctx)
  1549. offset-size (ctx-endianness ctx)
  1550. (ctx-meta ctx)
  1551. abbrevs ctx #f start (+ start 4 len) '())))
  1552. (define (make-child-context die)
  1553. (let ((ctx (die-ctx die)))
  1554. (add-to-parent!
  1555. (make-dwarf-context (ctx-bv ctx)
  1556. (ctx-offset-size ctx) (ctx-endianness ctx)
  1557. (ctx-meta ctx)
  1558. (ctx-abbrevs ctx)
  1559. ctx die
  1560. (die-next-offset die)
  1561. (die-sibling ctx (die-abbrev die) (die-offset die))
  1562. '()))))
  1563. (define (ctx-language ctx)
  1564. (or (and=> (ctx-die ctx) (lambda (x) (die-ref x 'language)))
  1565. (and=> (ctx-parent ctx) ctx-language)))
  1566. (define (populate-context-tree! die)
  1567. (define (skip? ctx offset abbrev)
  1568. (case (abbrev-tag abbrev)
  1569. ((class-type structure-type namespace) #f)
  1570. (else #t)))
  1571. (case (die-tag die)
  1572. ((compile-unit class-type structure-type namespace)
  1573. (let ((ctx (make-child-context die)))
  1574. ;; For C++, descend into classes and structures so that we
  1575. ;; populate the context tree. Note that for compile-unit, we
  1576. ;; still need to call `make-child-context' for its side effect of
  1577. ;; adding to the context tree.
  1578. (when (eq? (ctx-language ctx) 'c++)
  1579. (fold-die-children die
  1580. (lambda (die seed) (populate-context-tree! die))
  1581. #f
  1582. #:skip? skip?))))))
  1583. (define (read-compilation-unit ctx pos)
  1584. (let*-values (((start) pos)
  1585. ((len pos offset-size) (read-initial-length ctx pos))
  1586. ((version pos) (read-u16 ctx pos))
  1587. ((abbrevs-offset pos) (read-offset ctx pos offset-size))
  1588. ((av) (read-abbrevs ctx abbrevs-offset))
  1589. ((addrsize pos) (read-u8 ctx pos))
  1590. ((ctx) (make-compilation-unit-context ctx offset-size addrsize
  1591. av start len))
  1592. ((die pos) (read-die ctx pos)))
  1593. (populate-context-tree! die)
  1594. (values die (ctx-end ctx))))
  1595. (define (read-die-roots ctx)
  1596. (let lp ((dies '()) (pos (meta-info-start (ctx-meta ctx))))
  1597. (if (< pos (meta-info-end (ctx-meta ctx)))
  1598. (let-values (((die pos) (read-compilation-unit ctx pos)))
  1599. (if die
  1600. (lp (cons die dies) pos)
  1601. (reverse dies)))
  1602. (reverse dies))))
  1603. (define (fold-pubname-set ctx pos folder seed)
  1604. (let*-values (((len pos offset-size) (read-initial-length ctx pos))
  1605. ((version pos) (read-u16 ctx pos))
  1606. ((info-offset pos) (read-offset ctx pos offset-size))
  1607. ((info-offset) (+ info-offset
  1608. (meta-info-start (ctx-meta ctx))))
  1609. ((info-len pos) (read-offset ctx pos offset-size)))
  1610. (let lp ((pos pos) (seed seed))
  1611. (let-values (((offset pos) (read-offset ctx pos offset-size)))
  1612. (if (zero? offset)
  1613. (values seed pos)
  1614. (let-values (((str pos) (read-string ctx pos)))
  1615. (lp pos
  1616. (folder str (+ offset info-offset) seed))))))))
  1617. (define (fold-pubnames ctx folder seed)
  1618. (let ((end (meta-pubnames-end (ctx-meta ctx))))
  1619. (if end
  1620. (let lp ((pos (meta-pubnames-start (ctx-meta ctx))) (seed seed))
  1621. (if (< pos end)
  1622. (let-values (((seed pos) (fold-pubname-set ctx pos folder seed)))
  1623. (lp pos seed))
  1624. seed))
  1625. seed)))
  1626. (define (align address alignment)
  1627. (+ address
  1628. (modulo (- alignment (modulo address alignment)) alignment)))
  1629. (define (fold-arange-set ctx pos folder seed)
  1630. (let*-values (((len pos offset-size) (read-initial-length ctx pos))
  1631. ((version pos) (read-u16 ctx pos))
  1632. ((info-offset pos) (read-offset ctx pos offset-size))
  1633. ((info-offset) (+ info-offset
  1634. (meta-info-start (ctx-meta ctx))))
  1635. ((addr-size pos) (read-u8 ctx pos))
  1636. ((segment-size pos) (read-u8 ctx pos)))
  1637. (let lp ((pos (align pos (* 2 (ctx-addr-size ctx)))) (seed seed))
  1638. (let*-values (((addr pos) (read-addr ctx pos))
  1639. ((len pos) (read-addr ctx pos)))
  1640. (if (and (zero? addr) (zero? len))
  1641. (values seed pos)
  1642. (lp pos
  1643. (folder info-offset addr len seed)))))))
  1644. (define (fold-aranges ctx folder seed)
  1645. (let ((end (meta-aranges-end (ctx-meta ctx))))
  1646. (if end
  1647. (let lp ((pos (meta-aranges-start (ctx-meta ctx))) (seed seed))
  1648. (if (< pos end)
  1649. (let-values (((seed pos) (fold-arange-set ctx pos folder seed)))
  1650. (lp pos seed))
  1651. seed))
  1652. seed)))
  1653. (define* (elf->dwarf-context elf #:key (vaddr 0) (memsz 0)
  1654. (path #f) (lib-path path))
  1655. (let* ((sections (elf-sections-by-name elf))
  1656. (info (assoc-ref sections ".debug_info"))
  1657. (abbrevs (assoc-ref sections ".debug_abbrev"))
  1658. (strtab (assoc-ref sections ".debug_str"))
  1659. (loc (assoc-ref sections ".debug_loc"))
  1660. (line (assoc-ref sections ".debug_line"))
  1661. (pubnames (assoc-ref sections ".debug_pubnames"))
  1662. (aranges (assoc-ref sections ".debug_aranges")))
  1663. (make-dwarf-context (elf-bytes elf)
  1664. 4 ;; initial offset size
  1665. (elf-byte-order elf)
  1666. (make-dwarf-meta
  1667. (elf-word-size elf)
  1668. vaddr memsz
  1669. path lib-path
  1670. (elf-section-offset info)
  1671. (+ (elf-section-offset info)
  1672. (elf-section-size info))
  1673. (elf-section-offset abbrevs)
  1674. (+ (elf-section-offset abbrevs)
  1675. (elf-section-size abbrevs))
  1676. (elf-section-offset strtab)
  1677. (+ (elf-section-offset strtab)
  1678. (elf-section-size strtab))
  1679. (elf-section-offset loc)
  1680. (+ (elf-section-offset loc)
  1681. (elf-section-size loc))
  1682. (and line
  1683. (elf-section-offset line))
  1684. (and line
  1685. (+ (elf-section-offset line)
  1686. (elf-section-size line)))
  1687. (and pubnames
  1688. (elf-section-offset pubnames))
  1689. (and pubnames
  1690. (+ (elf-section-offset pubnames)
  1691. (elf-section-size pubnames)))
  1692. (and aranges
  1693. (elf-section-offset aranges))
  1694. (and aranges
  1695. (+ (elf-section-offset aranges)
  1696. (elf-section-size aranges))))
  1697. #() #f #f
  1698. (elf-section-offset info)
  1699. (+ (elf-section-offset info)
  1700. (elf-section-size info))
  1701. '())))
  1702. (define (die->tree die)
  1703. (cons* (die-tag die)
  1704. (cons 'offset (die-offset die))
  1705. (reverse! (fold-die-children
  1706. die
  1707. (lambda (die seed)
  1708. (cons (die->tree die) seed))
  1709. (fold acons '() (die-attrs die) (die-vals die))))))