#########################################################################
#                                                                       #
#                                 OCaml                                 #
#                                                                       #
#                 Damien Doligez, Jane Street Capital                   #
#                                                                       #
#   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
      set $camlcheckheader_result = 1
    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
      printf "[**invalid header**]"
    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"
  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
      printf "OUT-OF-HEAP"
    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
  camlheap $arg0
  printf " "
  camlheader $arg0
  set $mysize = $size
  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
    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] %#016lx ", $adr, $count, $field
      if ($field & 7) == 0 && $isvalues
        camlheap $field
        printf " "
        camlheader $field
      end
      if ($field & 1) == 1
        camlint $field
      end
      printf "\n"        
      set $count = $count + 1
    end
    if $count < $mysize
      printf "... truncated ...\n"
    end
  end    
end

define caml
  if ($arg0 & 1) == 1
    camlint $arg0
    printf "\n"
  end
  if ($arg0 & 7) == 0
    camlblock $arg0
  end
  if ($arg0 & 7) != 0 && ($arg0 & 1) != 1
    printf "invalid pointer: %#016lx\n", $arg0
  end
end
