#!perl -w
$|=1;
# z:/sources/wince500/PRIVATE/WINCEOS/COREOS/CORE/LMEM/heap.h
# 7c070000: 50616548  DWORD   dwSig;                  // 00: heap signature "HeaP"
#           00000000  pvaitem pvaList;                // 04: list of VirtualAlloc'ed items
#           0a120000  pheap   phpNext;                // 08: next heap in linked list of all heaps
#           00001000  WORD    flOptions;              // 0C: options from HeapCreate
# 7c070010: 00000000  DWORD   cbMaximum;              // 10: maximum size of this heap (0 == growable)
#           03f01c20  PFN_AllocHeapMem pfnAlloc;      // 14: allocator
#           03f01c4c  PFN_FreeHeapMem pfnFree;        // 18: de-allocator
#           00000001  CRITICAL_SECTION cs;            // 1c: critical section controlling this heap.
# 7c070020: 00000000                                                                                   
#           8f68bd30                                                                                   
#           00000000                                                                                   
#           00000000                                                                                   
#                      region  rgn;                    // 30: first memory region in this heap
# 7c070030: 7c0833e8     pitem   pitFree;                // 00: ptr to next available allocation
#           7c070030     pregion prgnLast;               // 04: ptr to last region (only valid for the original region)
#           00000ff1     int     cbMaxFree;              // 08: size of largest free item in this region
#           7c0833e8     pitem   pitLast;                // 0C: last free item proceeding end-marker (or end-marker itself)
# 7c070040: 7c070000     pheap   phpOwner;               // 10: ptr to heap this region is part of
#           00000000     pregion prgnNext;               // 14: ptr to next region in the heap
#           00000000     DWORD   dwRgnData;              // 18: data for allocator
#           00000000     DWORD   pad;                    // 1c: padding
# 7c070050: 00000000 00000000                  
# 
# sms3.mem  - after login
# sms2.mem  - after open inbox + contacts
# sms1.mem  - after lock

package MemImage;
use strict;
use IO::File;
sub new {
    my ($class, $filename, $base)= @_;
    my $fh= IO::File->new($filename, "r") or die "$filename: $!\n";
    my $self= {
        filename=>$filename,
        base=>$base,
        fh=>$fh,
    };
    return bless $self, $class;
}
sub readdata {
    my ($self, $ofs, $len)= @_;
    if ($ofs>=$self->{base} && $ofs<$self->{base}+0x02000000) {
        $ofs-=$self->{base};
    }
    if ($ofs>=0x02000000) {
        warn sprintf("unknown offset: %08lx\n", $ofs);
        return;
    }
    my $data;
    $self->{fh}->seek($ofs, SEEK_SET);
    $self->{fh}->read($data, $len);
    return $data;
}
sub readdw {
    my ($self, $ofs)= @_;
    return unpack("V", $self->readdata($ofs, 4));
}

package main;
use strict;
# from startheap, follow phpNext
#   for each heap:
#      follow prgnNext
#   for each region:
#      dump block list
#   calc free space, used space
#
sub parseHeapHeader {
    my %hdr;
    (
        $hdr{dwSig},
        $hdr{pvaList},
        $hdr{phpNext},
        $hdr{flOptions},
        $hdr{cbMaximum},
        $hdr{pfnAlloc},
        $hdr{pfnFree},
        $hdr{cs},
    )= unpack("V7a20", $_[0]);
    return \%hdr;
}
sub parseRegionHeader {
    my %hdr;
    (
        $hdr{pitFree},
        $hdr{prgnLast},
        $hdr{cbMaxFree},
        $hdr{pitLast},
        $hdr{phpOwner},
        $hdr{prgnNext},
        $hdr{dwRgnData},
        $hdr{pad},
    )= unpack("V8", $_[0]);
    return \%hdr;
}

my $filename=shift;
my $base=eval(shift);
my $firstheap=eval(shift);

my $mem= MemImage->new($filename, $base);
my $hofs= $firstheap;

my %stats;
while ($hofs)
{
    printf("---h:%08lx\n", $hofs);
    my $hdata= $mem->readdata($hofs, 48);
    my $heap= parseHeapHeader($hdata);
    printf("heapsig: %08lx\n", $heap->{dwSig}) if ($heap->{dwSig}!=0x50616548);
    my $rofs= $hofs+0x30;
    while ($rofs)
    {
        printf("---r:%08lx\n", $rofs);
        my $rdata= $mem->readdata($rofs, 0x20);
        my $region= parseRegionHeader($rdata);

        my $iofs= $rofs+0x28;
        while ($iofs<$region->{pitLast}) {
            my $idata= $mem->readdata($iofs, 8);
            my ($size, $ptr)= unpack("lV", $idata);
            my $type;
            if ($size>0 && $ptr==$rofs) {
                $type= 'busy';
            }
            elsif ($size<0) {
                $type= 'free';
                $size = -$size;
            }
            elsif ($size>0 && $ptr==0) {
                $type= 'hole';
            }
            elsif ($size==0) {
                $type= 'tail';
                $size= $ptr;
            }
            else {
                printf("!!! unhandled case: %08lx: size=%08lx ptr=%08lx\n", $iofs, $size, $ptr);
            }
            printf("%08lx-%08lx: %s : %s\n", $iofs+8, $iofs+8+$size, $type, unpack("H*", $mem->readdata($iofs+8, $size<64?$size:64)));
            $stats{$type}{total} += $size;
            $stats{$type}{hdr} += 8;
            $stats{$type}{x}{$size}++;
            $iofs+=$size;

            while (($iofs&0xf)!=8) {
                $iofs++;
            }
        }
        printf("region: %08lx-%08lx\n", $rofs, $iofs);
        $rofs= $region->{prgnNext};
    }
    $hofs= $heap->{phpNext};
}
printf("\n");
for my $t (qw(busy free hole tail)) {
    next unless $stats{$t}{hdr};
    printf("%s : user:%08lx hdr:%08lx  -> %08lx\n", $t, $stats{$t}{total}, $stats{$t}{hdr}, $stats{$t}{total}+$stats{$t}{hdr});
    for my $x (sort { $a<=>$b } keys %{$stats{$t}{x}}) {
        printf("    %8x : %8d\n", $x, $stats{$t}{x}{$x});
    }
}