319 lines
8.3 KiB
Plaintext
319 lines
8.3 KiB
Plaintext
#########################################################################
|
|
# #
|
|
# OCaml #
|
|
# #
|
|
# Damien Doligez, Jane Street Group, LLC #
|
|
# #
|
|
# Copyright 2015 Institut National de Recherche en Informatique et #
|
|
# en Automatique. All rights reserved. This file is distributed #
|
|
# under the terms of the Q Public License version 1.0. #
|
|
# #
|
|
#########################################################################
|
|
|
|
# A set of macros for low-level debugging of OCaml programs and of the
|
|
# OCaml runtime itself (both native and byte-code).
|
|
|
|
# This file should be loaded in gdb with [ source gdb-macros ].
|
|
# It defines one command: [caml]
|
|
# Usage:
|
|
# [caml <value>]
|
|
# If <value> is an OCaml value, this will display it in a low-level
|
|
# but legible format, including the header information.
|
|
|
|
# To do: a [camlsearch] command to find all (gc-traceable) pointers to
|
|
# a given heap block.
|
|
|
|
set $camlwordsize = sizeof(char *)
|
|
|
|
if $camlwordsize == 8
|
|
set $caml_unalloc_mask = 0xFF00FFFFFF00FFFF
|
|
set $caml_unalloc_value = 0xD700D7D7D700D6D7
|
|
else
|
|
set $caml_unalloc_mask = 0xFF00FFFF
|
|
set $caml_unalloc_value = 0xD700D6D7
|
|
end
|
|
|
|
define camlcheckheader
|
|
if $arg0 >> 10 <= 0 || $arg0 >> 10 >= 0x1000000000000
|
|
if ($arg0 & $caml_unalloc_mask) == $caml_unalloc_value
|
|
set $camlcheckheader_result = 2
|
|
else
|
|
if $arg0 == (unsigned long) 0
|
|
set $camlcheckheader_result = 3
|
|
else
|
|
set $camlcheckheader_result = 1
|
|
end
|
|
end
|
|
else
|
|
set $camlcheckheader_result = 0
|
|
end
|
|
end
|
|
|
|
define camlheader
|
|
set $hd = * (unsigned long *) ($arg0 - $camlwordsize)
|
|
set $tag = $hd & 0xFF
|
|
set $color = ($hd >> 8) & 3
|
|
set $size = $hd >> 10
|
|
|
|
camlcheckheader $hd
|
|
if $camlcheckheader_result != 0
|
|
if $camlcheckheader_result == 2
|
|
printf "[UNALLOCATED MEMORY]"
|
|
else
|
|
if $camlcheckheader_result == 3
|
|
printf "[** fragment **] 0x%016lu", $hd
|
|
else
|
|
printf "[**invalid header**] 0x%016lu", $hd
|
|
end
|
|
end
|
|
set $size = 0
|
|
else
|
|
printf "["
|
|
if $color == 0
|
|
printf "white "
|
|
end
|
|
if $color == 1
|
|
printf "gray "
|
|
end
|
|
if $color == 2
|
|
printf "blue "
|
|
end
|
|
if $color == 3
|
|
printf "black "
|
|
end
|
|
|
|
if $tag < 246
|
|
printf "tag%d ", $tag
|
|
end
|
|
if $tag == 246
|
|
printf "Lazy "
|
|
end
|
|
if $tag == 247
|
|
printf "Closure "
|
|
end
|
|
if $tag == 248
|
|
printf "Object "
|
|
end
|
|
if $tag == 249
|
|
printf "Infix "
|
|
end
|
|
if $tag == 250
|
|
printf "Forward "
|
|
end
|
|
if $tag == 251
|
|
printf "Abstract "
|
|
end
|
|
if $tag == 252
|
|
printf "String "
|
|
end
|
|
if $tag == 253
|
|
printf "Double "
|
|
end
|
|
if $tag == 254
|
|
printf "Double_array "
|
|
end
|
|
if $tag == 255
|
|
printf "Custom "
|
|
end
|
|
|
|
printf "%lu]", $size
|
|
end
|
|
end
|
|
|
|
define camlheap
|
|
if $arg0 >= caml_young_start && $arg0 < caml_young_end
|
|
printf "YOUNG"
|
|
set $camlheap_result = 1
|
|
else
|
|
set $chunk = caml_heap_start
|
|
set $found = 0
|
|
while $chunk != 0 && ! $found
|
|
set $chunk_size = * (unsigned long *) ($chunk - 2 * $camlwordsize)
|
|
if $arg0 > $chunk && $arg0 <= $chunk + $chunk_size
|
|
printf "OLD"
|
|
set $found = 1
|
|
end
|
|
set $chunk = * (unsigned long *) ($chunk - $camlwordsize)
|
|
end
|
|
if $found
|
|
set $camlheap_result = 1
|
|
else
|
|
printf "OUT-OF-HEAP"
|
|
set $camlheap_result = 0
|
|
end
|
|
end
|
|
end
|
|
|
|
define camlint
|
|
if ($arg0 & $caml_unalloc_mask) == $caml_unalloc_value
|
|
printf "UNALLOCATED MEMORY"
|
|
else
|
|
printf "INT %ld", ($arg0 >> 1)
|
|
end
|
|
if ($arg0 & 0xFF) == 0xF9 && ($arg0 >> 10) < 0x1000000000000
|
|
printf " [possible infix header]"
|
|
end
|
|
end
|
|
|
|
define camlblock
|
|
printf "%#lx: ", $arg0 - $camlwordsize
|
|
camlheap $arg0
|
|
printf " "
|
|
camlheader $arg0
|
|
set $mysize = $size
|
|
set $camlnext = $arg0 + $camlwordsize * ($size + 1)
|
|
printf "\n"
|
|
|
|
if $tag == 252
|
|
x/s $arg0
|
|
end
|
|
if $tag == 253
|
|
x/f $arg0
|
|
end
|
|
if $tag == 254
|
|
while $count < $mysize && $count < 10
|
|
if $count + 1 < $size
|
|
x/2f $arg0 + $camlwordsize * $count
|
|
else
|
|
x/f $arg0 + $camlwordsize * $count
|
|
end
|
|
set $count = $count + 2
|
|
end
|
|
if $count < $mysize
|
|
printf "... truncated ...\n"
|
|
end
|
|
end
|
|
|
|
if $tag == 249
|
|
printf "... infix header, displaying enclosing block:\n"
|
|
set $mybaseaddr = $arg0 - $camlwordsize * $mysize
|
|
camlblock $mybaseaddr
|
|
# reset $tag, which was clobbered by the recursive call (yuck)
|
|
set $tag = 249
|
|
end
|
|
|
|
if $tag != 249 && $tag != 252 && $tag != 253 && $tag != 254
|
|
set $isvalues = $tag < 251
|
|
set $count = 0
|
|
while $count < $mysize && $count < 10
|
|
set $adr = $arg0 + $camlwordsize * $count
|
|
set $field = * (unsigned long *) $adr
|
|
printf "%#lx: [%d] 0x%016lx ", $adr, $count, $field
|
|
if ($field & 7) == 0 && $isvalues
|
|
camlheap $field
|
|
if $camlheap_result
|
|
printf " "
|
|
camlheader $field
|
|
end
|
|
end
|
|
if ($field & 1) == 1
|
|
camlint $field
|
|
end
|
|
printf "\n"
|
|
set $count = $count + 1
|
|
end
|
|
if $count < $mysize
|
|
printf "... truncated ...\n"
|
|
end
|
|
end
|
|
printf "next block head: %#lx value: %#lx\n", \
|
|
$arg0 + $camlwordsize * $mysize, $arg0 + $camlwordsize * ($mysize+1)
|
|
end
|
|
|
|
# displays an OCaml value
|
|
define caml
|
|
set $camllast = (long) $arg0
|
|
if ($camllast & 1) == 1
|
|
set $camlnext = 0
|
|
camlint $camllast
|
|
printf "\n"
|
|
end
|
|
if ($camllast & 7) == 0
|
|
camlblock $camllast
|
|
end
|
|
if ($camllast & 7) != 0 && ($camllast & 1) != 1
|
|
set $camlnext = 0
|
|
printf "invalid pointer: %#016lx\n", $camllast
|
|
end
|
|
end
|
|
|
|
# displays the next OCaml value in memory
|
|
define camlnext
|
|
caml $camlnext
|
|
end
|
|
|
|
# displays the n-th field of the previously displayed value
|
|
define camlfield
|
|
set $camlfield_addr = ((long *) $camllast)[$arg0]
|
|
caml $camlfield_addr
|
|
end
|
|
|
|
# displays the list of heap chunks
|
|
define camlchunks
|
|
set $chunk = * (unsigned long *) &caml_heap_start
|
|
while $chunk != 0
|
|
set $chunk_size = * (unsigned long *) ($chunk - 2 * $camlwordsize)
|
|
set $chunk_alloc = * (unsigned long *) ($chunk - 3 * $camlwordsize)
|
|
printf "chunk: addr = %#lx .. %#lx", $chunk, $chunk + $chunk_size
|
|
printf " (size = %#lx; alloc = %#lx)\n", $chunk_size, $chunk_alloc
|
|
set $chunk = * (unsigned long *) ($chunk - $camlwordsize)
|
|
end
|
|
end
|
|
|
|
# walk the heap and launch command `camlvisitfun` on each block
|
|
# the variables `$hp` `$val` `$hd` `$tag` `$color` and `$size`
|
|
# are set before calling `camlvisitfun`
|
|
# `camlvisitfun` can set `$camlvisitstop` to stop the iteration
|
|
|
|
define camlvisit
|
|
set $cvchunk = * (unsigned long *) &caml_heap_start
|
|
set $camlvisitstop = 0
|
|
while $cvchunk != 0 && ! $camlvisitstop
|
|
set $cvchunk_size = * (unsigned long *) ($cvchunk - 2 * $camlwordsize)
|
|
set $cvhp = $cvchunk
|
|
while $cvhp < $cvchunk + $cvchunk_size && !$camlvisitstop
|
|
set $hp = $cvhp
|
|
set $val = $hp + $camlwordsize
|
|
set $hd = * (unsigned long *) $hp
|
|
set $tag = $hd & 0xFF
|
|
set $color = ($hd >> 8) & 3
|
|
set $cvsize = $hd >> 10
|
|
set $size = $cvsize
|
|
camlvisitfun
|
|
set $cvhp = $cvhp + (($cvsize + 1) * $camlwordsize)
|
|
end
|
|
set $cvchunk = * (unsigned long *) ($cvchunk - $camlwordsize)
|
|
end
|
|
end
|
|
|
|
define caml_cv_check_fl0
|
|
if $hp == * (unsigned long *) &caml_heap_start
|
|
set $flcheck_prev = ((unsigned long) &sentinels + 16)
|
|
end
|
|
if $color == 2 && $size > 5
|
|
if $val != * (unsigned long *) $flcheck_prev
|
|
printf "free-list: missing link %#x -> %#x\n", $flcheck_prev, $val
|
|
set $camlvisitstop = 1
|
|
end
|
|
set $flcheck_prev = $val
|
|
end
|
|
end
|
|
|
|
define caml_check_fl
|
|
set $listsize = $arg0
|
|
set $blueseen = $listsize == 0
|
|
set $val = * (unsigned long *) ((long) &sentinels + 16 + 32 * $listsize)
|
|
while $val != 0
|
|
printf "%#x\n", $val
|
|
set $hd = * (unsigned long *) ($val - 8)
|
|
set $color = ($hd >> 8) & 3
|
|
if $blueseen && $color != 2
|
|
printf "non-blue block at address %#x\n", $val
|
|
loop_break
|
|
else
|
|
set $blueseen = 1
|
|
end
|
|
set $val = * (unsigned long *) $val
|
|
end
|
|
end
|