1#************************************************************************** 2#* * 3#* OCaml * 4#* * 5#* Damien Doligez, Jane Street Group, LLC * 6#* * 7#* Copyright 2015 Institut National de Recherche en Informatique et * 8#* en Automatique. * 9#* * 10#* All rights reserved. This file is distributed under the terms of * 11#* the GNU Lesser General Public License version 2.1, with the * 12#* special exception on linking described in the file LICENSE. * 13#* * 14#************************************************************************** 15 16# A set of macros for low-level debugging of OCaml programs and of the 17# OCaml runtime itself (both native and byte-code). 18 19# This file should be loaded in gdb with [ source gdb-macros ]. 20# It defines one command: [caml] 21# Usage: 22# [caml <value>] 23# If <value> is an OCaml value, this will display it in a low-level 24# but legible format, including the header information. 25 26# To do: a [camlsearch] command to find all (gc-traceable) pointers to 27# a given heap block. 28 29set $camlwordsize = sizeof(char *) 30 31if $camlwordsize == 8 32 set $caml_unalloc_mask = 0xFF00FFFFFF00FFFF 33 set $caml_unalloc_value = 0xD700D7D7D700D6D7 34else 35 set $caml_unalloc_mask = 0xFF00FFFF 36 set $caml_unalloc_value = 0xD700D6D7 37end 38 39define camlcheckheader 40 if $arg0 >> 10 <= 0 || $arg0 >> 10 >= 0x1000000000000 41 if ($arg0 & $caml_unalloc_mask) == $caml_unalloc_value 42 set $camlcheckheader_result = 2 43 else 44 if $arg0 == (unsigned long) 0 45 set $camlcheckheader_result = 3 46 else 47 set $camlcheckheader_result = 1 48 end 49 end 50 else 51 set $camlcheckheader_result = 0 52 end 53end 54 55define camlheader 56 set $hd = * (unsigned long *) ($arg0 - $camlwordsize) 57 set $tag = $hd & 0xFF 58 set $color = ($hd >> 8) & 3 59 set $size = $hd >> 10 60 61 camlcheckheader $hd 62 if $camlcheckheader_result != 0 63 if $camlcheckheader_result == 2 64 printf "[UNALLOCATED MEMORY]" 65 else 66 if $camlcheckheader_result == 3 67 printf "[** fragment **] 0x%016lu", $hd 68 else 69 printf "[**invalid header**] 0x%016lu", $hd 70 end 71 end 72 set $size = 0 73 else 74 printf "[" 75 if $color == 0 76 printf "white " 77 end 78 if $color == 1 79 printf "gray " 80 end 81 if $color == 2 82 printf "blue " 83 end 84 if $color == 3 85 printf "black " 86 end 87 88 if $tag < 246 89 printf "tag%d ", $tag 90 end 91 if $tag == 246 92 printf "Lazy " 93 end 94 if $tag == 247 95 printf "Closure " 96 end 97 if $tag == 248 98 printf "Object " 99 end 100 if $tag == 249 101 printf "Infix " 102 end 103 if $tag == 250 104 printf "Forward " 105 end 106 if $tag == 251 107 printf "Abstract " 108 end 109 if $tag == 252 110 printf "String " 111 end 112 if $tag == 253 113 printf "Double " 114 end 115 if $tag == 254 116 printf "Double_array " 117 end 118 if $tag == 255 119 printf "Custom " 120 end 121 122 printf "%lu]", $size 123 end 124end 125 126define camlheap 127 if $arg0 >= caml_young_start && $arg0 < caml_young_end 128 printf "YOUNG" 129 set $camlheap_result = 1 130 else 131 set $chunk = caml_heap_start 132 set $found = 0 133 while $chunk != 0 && ! $found 134 set $chunk_size = * (unsigned long *) ($chunk - 2 * $camlwordsize) 135 if $arg0 > $chunk && $arg0 <= $chunk + $chunk_size 136 printf "OLD" 137 set $found = 1 138 end 139 set $chunk = * (unsigned long *) ($chunk - $camlwordsize) 140 end 141 if $found 142 set $camlheap_result = 1 143 else 144 printf "OUT-OF-HEAP" 145 set $camlheap_result = 0 146 end 147 end 148end 149 150define camlint 151 if ($arg0 & $caml_unalloc_mask) == $caml_unalloc_value 152 printf "UNALLOCATED MEMORY" 153 else 154 printf "INT %ld", ($arg0 >> 1) 155 end 156 if ($arg0 & 0xFF) == 0xF9 && ($arg0 >> 10) < 0x1000000000000 157 printf " [possible infix header]" 158 end 159end 160 161define camlblock 162 printf "%#lx: ", $arg0 - $camlwordsize 163 camlheap $arg0 164 printf " " 165 camlheader $arg0 166 set $mysize = $size 167 set $camlnext = $arg0 + $camlwordsize * ($size + 1) 168 printf "\n" 169 170 if $tag == 252 171 x/s $arg0 172 end 173 if $tag == 253 174 x/f $arg0 175 end 176 if $tag == 254 177 while $count < $mysize && $count < 10 178 if $count + 1 < $size 179 x/2f $arg0 + $camlwordsize * $count 180 else 181 x/f $arg0 + $camlwordsize * $count 182 end 183 set $count = $count + 2 184 end 185 if $count < $mysize 186 printf "... truncated ...\n" 187 end 188 end 189 190 if $tag == 249 191 printf "... infix header, displaying enclosing block:\n" 192 set $mybaseaddr = $arg0 - $camlwordsize * $mysize 193 camlblock $mybaseaddr 194 # reset $tag, which was clobbered by the recursive call (yuck) 195 set $tag = 249 196 end 197 198 if $tag != 249 && $tag != 252 && $tag != 253 && $tag != 254 199 set $isvalues = $tag < 251 200 set $count = 0 201 while $count < $mysize && $count < 10 202 set $adr = $arg0 + $camlwordsize * $count 203 set $field = * (unsigned long *) $adr 204 printf "%#lx: [%d] 0x%016lx ", $adr, $count, $field 205 if ($field & 7) == 0 && $isvalues 206 camlheap $field 207 if $camlheap_result 208 printf " " 209 camlheader $field 210 end 211 end 212 if ($field & 1) == 1 213 camlint $field 214 end 215 printf "\n" 216 set $count = $count + 1 217 end 218 if $count < $mysize 219 printf "... truncated ...\n" 220 end 221 end 222 printf "next block head: %#lx value: %#lx\n", \ 223 $arg0 + $camlwordsize * $mysize, $arg0 + $camlwordsize * ($mysize+1) 224end 225 226# displays an OCaml value 227define caml 228 set $camllast = (long) $arg0 229 if ($camllast & 1) == 1 230 set $camlnext = 0 231 camlint $camllast 232 printf "\n" 233 end 234 if ($camllast & 7) == 0 235 camlblock $camllast 236 end 237 if ($camllast & 7) != 0 && ($camllast & 1) != 1 238 set $camlnext = 0 239 printf "invalid pointer: %#016lx\n", $camllast 240 end 241end 242 243# displays the next OCaml value in memory 244define camlnext 245 caml $camlnext 246end 247 248# displays the n-th field of the previously displayed value 249define camlfield 250 set $camlfield_addr = ((long *) $camllast)[$arg0] 251 caml $camlfield_addr 252end 253 254# displays the list of heap chunks 255define camlchunks 256 set $chunk = * (unsigned long *) &caml_heap_start 257 while $chunk != 0 258 set $chunk_size = * (unsigned long *) ($chunk - 2 * $camlwordsize) 259 set $chunk_alloc = * (unsigned long *) ($chunk - 3 * $camlwordsize) 260 printf "chunk: addr = %#lx .. %#lx", $chunk, $chunk + $chunk_size 261 printf " (size = %#lx; alloc = %#lx)\n", $chunk_size, $chunk_alloc 262 set $chunk = * (unsigned long *) ($chunk - $camlwordsize) 263 end 264end 265 266# walk the heap and launch command `camlvisitfun` on each block 267# the variables `$hp` `$val` `$hd` `$tag` `$color` and `$size` 268# are set before calling `camlvisitfun` 269# `camlvisitfun` can set `$camlvisitstop` to stop the iteration 270 271define camlvisit 272 set $cvchunk = * (unsigned long *) &caml_heap_start 273 set $camlvisitstop = 0 274 while $cvchunk != 0 && ! $camlvisitstop 275 set $cvchunk_size = * (unsigned long *) ($cvchunk - 2 * $camlwordsize) 276 set $cvhp = $cvchunk 277 while $cvhp < $cvchunk + $cvchunk_size && !$camlvisitstop 278 set $hp = $cvhp 279 set $val = $hp + $camlwordsize 280 set $hd = * (unsigned long *) $hp 281 set $tag = $hd & 0xFF 282 set $color = ($hd >> 8) & 3 283 set $cvsize = $hd >> 10 284 set $size = $cvsize 285 camlvisitfun 286 set $cvhp = $cvhp + (($cvsize + 1) * $camlwordsize) 287 end 288 set $cvchunk = * (unsigned long *) ($cvchunk - $camlwordsize) 289 end 290end 291 292define caml_cv_check_fl0 293 if $hp == * (unsigned long *) &caml_heap_start 294 set $flcheck_prev = ((unsigned long) &sentinels + 16) 295 end 296 if $color == 2 && $size > 5 297 if $val != * (unsigned long *) $flcheck_prev 298 printf "free-list: missing link %#x -> %#x\n", $flcheck_prev, $val 299 set $camlvisitstop = 1 300 end 301 set $flcheck_prev = $val 302 end 303end 304 305define caml_check_fl 306 set $listsize = $arg0 307 set $blueseen = $listsize == 0 308 set $val = * (unsigned long *) ((long) &sentinels + 16 + 32 * $listsize) 309 while $val != 0 310 printf "%#x\n", $val 311 set $hd = * (unsigned long *) ($val - 8) 312 set $color = ($hd >> 8) & 3 313 if $blueseen && $color != 2 314 printf "non-blue block at address %#x\n", $val 315 loop_break 316 else 317 set $blueseen = 1 318 end 319 set $val = * (unsigned long *) $val 320 end 321end 322