#**************************************************************************
#*                                                                        *
#*                                 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 GNU Lesser General Public License version 2.1, with the          *
#*   special exception on linking described in the file LICENSE.          *
#*                                                                        *
#**************************************************************************

# A set of macros for low-level debugging of OCaml programs and of the
# OCaml runtime itself (both native and byte-code).

# Advice to future developers: rewrite this in Python which will be
# faster, more reliable, and more maintainable. See also gdb_ocamlrun.py

# This file should be loaded in gdb with [ source gdb-macros ].
# It defines a few related commands:
#
# Usage:
# [caml <value>]
# If <value> is an OCaml value, this will display it in a low-level
# but legible format, including the header information.
#
# [caml-next]
# If the most recent value shown with "caml" is a heap block,
# this will describe the following block.
#
# [caml-field <N>]
# If the most recent value shown with "caml" is a heap block,
# this will describe the Nth field in that block.

set $caml_word_size = sizeof(char *)
set $caml_word_bits = 8 * $caml_word_size
set $caml_pool_size = 4096 * $caml_word_size

if $caml_word_size == 8
  set $caml_unalloc_mask = 0xFF00FFFFFF00FFFF
  set $caml_unalloc_value = 0xD700D7D7D700D6D7
else
  set $caml_unalloc_mask = 0xFF00FFFF
  set $caml_unalloc_value = 0xD700D6D7
end

# `caml header item` Displays information about the header of a Caml
# block `item`, with no new-line.

define caml_header
  set $hd = * (unsigned long *) ($arg0 - $caml_word_size)
  set $tag = $hd & 0xFF
  set $color = $hd & (3 << 8)
  set $size = $hd >> 10

  if $size <= 0 || $size >= 0x1000000000000
    if ($hd & $caml_unalloc_mask) == $caml_unalloc_value
      printf "[UNALLOCATED MEMORY]"
    else
      if !$hd
        printf "[** fragment **] 0x%lx", $hd
      else
        printf "[** invalid header **] 0x%lx", $hd
      end
    end
  else
    printf "["
    if $color == caml_global_heap_state.MARKED
      printf "marked "
    end
    if $color == caml_global_heap_state.UNMARKED
      printf "unmarked "
    end
    if $color == caml_global_heap_state.GARBAGE
      printf "garbage "
    end
    if $color == 3 << 8
      printf "not markable "
    end

    if $tag < 244
      printf "tag %d ", $tag
    end
    if $tag == 244
      printf "Forcing "
    end
    if $tag == 245
      printf "Continuation "
    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

# Various caml_search_* functions which understand the layout of the
# Caml heap. Main driver function is "caml_search". This is slow and
# would benefit from being rewritten in a faster or more capable
# language (e.g. Python). To debug the heap searching itself, set
# $caml_search_debug=1.

# `caml_search_pools name pool item` searches the pool list from
# `pool` onwards for the block `item`. If found, it outputs `FOUND`
# and a description of the pool where it was found. If
# $caml_search_debug is set, it also describes all the pools on the
# list. `name` is a string describing the pool list.

define caml_search_pools
  set $pool = $arg1
  while $pool && ($caml_search_debug || !$found)
    set $found_here = 0
    if ($arg2 >= (char*)($pool+1)) && ($arg2 < (char*)$pool + $caml_pool_size)
      printf "FOUND"
      set $found_here = 1
      set $found = 1
    end
    if $caml_search_debug || $found_here
      printf " domain %d %s pool %lx-%lx sizeclass %d(%d)", \
             $domain_index, $arg0, $pool, ((char*)$pool)+$caml_pool_size, \
             $pool->sz, wsize_sizeclass[$pool->sz]
      if $caml_search_debug
        printf "\n"
      end
    end
    set $pool = $pool->next
  end
end

# `caml_search_large name large item` searches the large block list
# from `large` onwards for the block `item`. If found, it outputs
# `FOUND` and a description of the large block where it was found. If
# $caml_search_debug is set, it also describes all the large blocks
# on the list. `name` is a string describing the large object list.

define caml_search_large
  set $large = $arg1
  while $large && ($caml_search_debug || !$found)
    set $large_hd = * (unsigned long *)($large+1)
    set $large_size = ((($large_hd) >> 10)+1)*sizeof(unsigned long)
    set $large_end = ((char*)($large+1))+$large_size
    set $found_here = 0
    if ($arg2 > (char*)$large) && ($arg2 < $large_end)
      printf "FOUND"
      set $found_here = 1
      set $found = 1
    end
    if $caml_search_debug || $found_here
      printf " domain %d %s large %lx-%lx? (size %d?)", \
             $domain_index, $arg0, $large, $large_end, $large_size
      if $caml_search_debug
        printf "\n"
      end
    end
    set $large = $large->next
  end
end

# `caml_search_heap_state state item` searches the pool and large
# object lists in the caml_heap_state `state` for the block `item`.
# If found, it outputs `FOUND` and a description of the zone where it
# was found. If $caml_search_debug is set, it also describes all the
# areas searched.

define caml_search_heap_state
  set $heap_state = $arg0
  set $NUM_SIZECLASSES = sizeof($heap_state->avail_pools)/ \
                         sizeof($heap_state->avail_pools[0])
  set $sizeclass = 0
  while $sizeclass < $NUM_SIZECLASSES && ($caml_search_debug || !$found)
    caml_search_pools "avail" $heap_state->avail_pools[$sizeclass] $arg1
    caml_search_pools "full" $heap_state->full_pools[$sizeclass] $arg1
    caml_search_pools "unswept avail" \
                      $heap_state->unswept_avail_pools[$sizeclass] $arg1
    caml_search_pools "unswept full" \
                      $heap_state->unswept_full_pools[$sizeclass] $arg1
    set $sizeclass = $sizeclass + 1
  end
  caml_search_large "swept" $heap_state->swept_large $arg1
  caml_search_large "unswept" $heap_state->unswept_large $arg1
end

# `caml_search item` searches the entire Caml heap for `item` and
# outputs text describing the location, where it was found, with no
# new-line.

define caml_search
  set $Max_domains = sizeof(all_domains)/sizeof(all_domains[0])
  set $domain_index = 0
  set $found = 0
  while $domain_index < $Max_domains && !$found
    set $domain = all_domains + $domain_index
    if $domain->state != 0
        if $caml_search_debug
            printf "domain %d minor %lx-%lx\n", \
                   $domain_index, \
                   $domain->state->young_start, $domain->state->young_end
        end
        if $arg0 >= $domain->state->young_start && \
           $arg0 < $domain->state->young_end
          printf "FOUND young (domain %d)", $domain_index
          set $found = 1
        end
        if $caml_search_debug || !$found
           caml_search_heap_state $domain->state->shared_heap $arg0
        end
    end
    set $domain_index = $domain_index + 1
  end
  if $caml_search_debug
    printf "Global (orphaned) heap:\n"
  end
  if $caml_search_debug || !$found
    set $sizeclass = 0
    set $domain_index = -1
    while $sizeclass < $NUM_SIZECLASSES && ($caml_search_debug || !$found)
      caml_search_pools "global avail" \
                        pool_freelist.global_avail_pools[$sizeclass] $arg0
      caml_search_pools "global full" \
                        pool_freelist.global_full_pools[$sizeclass] $arg0
      set $sizeclass = $sizeclass + 1
    end
    caml_search_large "global large" pool_freelist.global_large $arg0
  end
  set $caml_search_result = $found
  if !$caml_search_result
    printf "not on Caml heap"
  end
end

# `caml_int item` describes `item`, with no new line, on the
# assumption that it's a Caml (tagged) integer.

define caml_int
  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

# `caml_summary item` outputs a short text description of `item`, with
# no newline.

define caml_summary
  if ($arg0 & 1) == 1
    caml_int $arg0
  end
  if ($arg0 & 7) == 0
    # aligned pointer
    caml_search $arg0
    printf " "
    caml_header $arg0
  end
  if ($arg0 & 1) == 0 && ($arg0 & 7)
    printf "UNALIGNED POINTER: %lx\n", $caml_last
  end
end

# `caml_block item` describes `item`, which should be a pointer to a
# Caml block, over several lines.

define caml_block
  printf "%#lx: ", $arg0 - $caml_word_size
  set $caml_block_ptr = $arg0
  caml_search $caml_block_ptr
  printf " "
  caml_header $caml_block_ptr
  set $caml_block_size = $size
  set $caml_block_tag = $tag
  set $caml_next = $caml_block_ptr + $caml_word_size * ($caml_block_size + 1)
  printf "\n"

  if $caml_block_tag == 252
    x/s $caml_block_ptr
  end
  if $caml_block_tag == 253
    x/f $caml_block_ptr
  end
  if $caml_block_tag == 254
    while $count < $caml_block_size && $count < 10
      if $count + 1 < $caml_block_size
        x/2f $caml_block_ptr + $caml_word_size * $count
      else
        x/f $caml_block_ptr + $caml_word_size * $count
      end
      set $count = $count + 2
    end
    if $count < $caml_block_size
      printf "... truncated ...\n"
    end
  end

  if $caml_block_tag == 249
    printf "... infix header, displaying enclosing block:\n"
    set $mybaseaddr = $caml_block_ptr - $caml_word_size * $caml_block_size
    set $save_ptr = $caml_block_ptr
    set $save_size = $caml_block_size
    caml_block $mybaseaddr
    # restore values clobbered by the recursive call (yuck)
    set $caml_block_tag = 249
    set $caml_block_ptr = $save_ptr
    set $caml_block_size = $save_size
  end

  if $caml_block_tag != 249 && $caml_block_tag != 252 && \
     $caml_block_tag != 253 && $caml_block_tag != 254
    set $isvalues = $caml_block_tag < 251
    set $count = 0
    while $count < $caml_block_size && $count < 10
      set $adr = $caml_block_ptr + $caml_word_size * $count
      set $field = * (unsigned long *) $adr
      printf "%#lx: [%d] 0x%016lx ", $adr, $count, $field
      # If closure, zeroth field is a code address.
      if $caml_block_tag == 247 && $count == 0
        printf "code address? "
      end
      # Decode closure information field
      if ($field & 1) == 1 && $caml_block_tag == 247 && $count == 1
        printf "arity %d non-scannable %d", \
               $field >> ($caml_word_bits - 8), \
               ($field & ((1ul << ($caml_word_bits-8))-1)) >> 1
      else
        caml_summary $field
      end
      printf "\n"
      set $count = $count + 1
    end
    if $count < $caml_block_size
      printf "... truncated ...\n"
    end
  end
  printf "next block head: %#lx   value: %#lx\n", \
         $caml_block_ptr + $caml_word_size * $caml_block_size, \
         $caml_block_ptr + $caml_word_size * ($caml_block_size+1)
end

# `caml item` describes the Caml value `item`, over several lines if
# appropriate. This function is the main point of this file.

define caml
  set $caml_last = $arg0
  set $caml_next = 0
  if ($caml_last & 1) == 1
    caml_int $caml_last
  end
  if ($caml_last & 7) == 0
    caml_block $caml_last
  end
  printf "\n"
end

document caml
Output a description of a the Caml value VALUE, in a low-level but legible
format, including information about where on the heap it is located, and any
header and fields it contains.
end

# displays the next OCaml value in memory
define caml_next
  if $caml_next
    caml $caml_next
  else
    printf "No next block\n"
  end
end

document caml_next
If the most recent value described was a heap block, "caml-next" describes
the following block on the heap.
end

# displays the n-th field of the previously displayed value
define caml_field
  set $caml_field = ((long *) $caml_last)[$arg0]
  caml $caml_field
end

document caml_field
If the most recent value described was a heap block, "caml-field N" describes
the Nth field in that block.
end