File Coverage

XS.xs

Criterion	Covered	Total	%
statement	104	130	80.0
branch	82	142	57.7
condition			n/a
subroutine			n/a
pod			n/a
total	186	272	68.3

#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include "ppport.h"

#define iParent(i)      (((i)-1) / 2)
#define iLeftChild(i)   ((2*(i)) + 1)
#define iRightChild(i)  ((2*(i)) + 2)

#define OUT_OF_ORDER(a,tmpsv,child_is_magic,parent_is_magic,child,parent,is_min)                \
    ( ( ( (child_is_magic) || (parent_is_magic) )                                               \
        ? (((tmpsv) = amagic_call((a)[(child)], (a)[(parent)], is_min & 2 ? sgt_amg : gt_amg, 0)) && SvTRUE((tmpsv)))  \
        : ( ((is_min & 2) ? Perl_sv_cmp(aTHX_ (a)[(child)], a[(parent)]) \
                          : my_Perl_do_ncmp(aTHX_ (a)[(child)], a[(parent)])) > 0) )\
      ? !(is_min & 1) : (is_min & 1) )

#define FORCE_SCALAR(fakeop)                    \
STMT_START {                                    \
        SAVEOP();                               \
        Copy(PL_op, &fakeop, 1, OP);            \
        fakeop.op_flags = OPf_WANT_SCALAR;      \
        PL_op = &fakeop;                        \
} STMT_END


#ifdef Perl_do_ncmp
#define my_Perl_do_ncmp Perl_do_ncmp
#else
/* compare left and right SVs. Returns:
 * -1: <
 *  0: ==
 *  1: >
 *  2: left or right was a NaN
 */
I32
my_Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
{
    PERL_ARGS_ASSERT_DO_NCMP;
#ifdef PERL_PRESERVE_IVUV
    /* Fortunately it seems NaN isn't IOK */
    if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
            if (!SvIsUV(left)) {
                const IV leftiv = SvIVX(left);
                if (!SvIsUV(right)) {
                    /* ## IV <=> IV ## */
                    const IV rightiv = SvIVX(right);
                    return (leftiv > rightiv) - (leftiv < rightiv);
                }
                /* ## IV <=> UV ## */
                if (leftiv < 0)
                    /* As (b) is a UV, it's >=0, so it must be < */
                    return -1;
                {
                    const UV rightuv = SvUVX(right);
                    return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
                }
            }

            if (SvIsUV(right)) {
                /* ## UV <=> UV ## */
                const UV leftuv = SvUVX(left);
                const UV rightuv = SvUVX(right);
                return (leftuv > rightuv) - (leftuv < rightuv);
            }
            /* ## UV <=> IV ## */
            {
                const IV rightiv = SvIVX(right);
                if (rightiv < 0)
                    /* As (a) is a UV, it's >=0, so it cannot be < */
                    return 1;
                {
                    const UV leftuv = SvUVX(left);
                    return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
                }
            }
            NOT_REACHED; /* NOTREACHED */
    }
#endif
    {
      NV const lnv = SvNV_nomg(left);
      NV const rnv = SvNV_nomg(right);

#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
      if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
          return 2;
       }
      return (lnv > rnv) - (lnv < rnv);
#else
      if (lnv < rnv)
        return -1;
      if (lnv > rnv)
        return 1;
      if (lnv == rnv)
        return 0;
      return 2;
#endif
    }
}
#endif


I32 sift_up(pTHX_ SV **a, ssize_t start, ssize_t end, I32 is_min) {
     /*start represents the limit of how far up the heap to sift.
       end is the node to sift up. */
    ssize_t child = end;
    SV *tmpsv = NULL;
    I32 child_is_magic;
    I32 swapped = 0;
    SvGETMAGIC(a[child]);
    child_is_magic= SvAMAGIC(a[child]);

    while (child > start) {
        ssize_t parent = iParent(child);
        I32 parent_is_magic;
        SvGETMAGIC(a[parent]);
        parent_is_magic= SvAMAGIC(a[parent]);
        if ( OUT_OF_ORDER(a,tmpsv,child_is_magic,parent_is_magic,child,parent,is_min) ) {
            SV *swap_tmp= a[parent];
            a[parent]= a[child];
            a[child]= swap_tmp;

            child = parent; /* repeat to continue sifting up the parent now */
            child_is_magic= parent_is_magic;
            swapped++;
        }
        else {
            return swapped;
        }
    }
    return swapped;
}

/*Repair the heap whose root element is at index 'start', assuming the heaps rooted at its children are valid*/
I32 sift_down(pTHX_ SV **a, ssize_t start, ssize_t end, I32 is_min) {
    ssize_t root = start;
    I32 root_is_magic = SvAMAGIC(a[root]);
    I32 swapped = 0;

    while (iLeftChild(root) <= end) {       /* While the root has at least one child */
        ssize_t child = iLeftChild(root);       /* Left child of root */
        I32 child_is_magic = SvAMAGIC(a[child]);
        ssize_t swap = root;                    /* Keeps track of child to swap with */
        I32 swap_is_magic = root_is_magic;
        SV *tmpsv = NULL;

        /* if the root is smaller than the left child
         *      then the swap is with the left child */
        if ( OUT_OF_ORDER(a,tmpsv,child_is_magic,swap_is_magic,child,swap,is_min) ) {
            swap = child;
            swap_is_magic = child_is_magic;
        }
        /* if there is a right child and the right child is larger than the root or the left child
         *      then the swap is with the right child */
        if (child+1 <= end) {
            child_is_magic = SvAMAGIC(a[child+1]);
            if ( OUT_OF_ORDER(a,tmpsv,child_is_magic,swap_is_magic,child+1,swap,is_min) ) {
                swap = child + 1;
                swap_is_magic = child_is_magic;
            }
        }
        /* check if we need to swap or if this tree is in heap-order */
        if (swap == root) {
            /* The root is larger than both children, and as we assume the heaps rooted at the children are valid
             * then we know we can stop. */
            return swapped;
        } else {
            /* swap the root with the largest child */
            SV *tmp= a[root];
            a[root]= a[swap];
            a[swap]= tmp;
            /* continue sifting down the child by setting the root to the chosen child
             * effectively we sink down the tree towards the leafs */
            root = swap;
            root_is_magic = swap_is_magic;
            swapped++;
        }
    }
    return swapped;
}

/* this is O(N log N) */
void heapify_with_sift_up(pTHX_ SV **a, ssize_t count, I32 is_min) {
    ssize_t end = 1; /* end is assigned the index of the first (left) child of the root */

    while (end < count) {
        /*sift up the node at index end to the proper place such that all nodes above
          the end index are in heap order */
        (void)sift_up(aTHX_ a, 0, end, is_min);
        end++;
    }
    /* after sifting up the last node all nodes are in heap order */
}

/* this is O(N) */
void heapify_with_sift_down(pTHX_ SV **a, ssize_t count, I32 is_min) {
    /*start is assigned the index in 'a' of the last parent node
      the last element in a 0-based array is at index count-1; find the parent of that element */
    ssize_t start = iParent(count-1);

    while (start >= 0) {
        /* sift down the node at index 'start' to the proper place such that all nodes below
         the start index are in heap order */
        (void)sift_down(aTHX_ a, start, count - 1, is_min);
        /* go to the next parent node */
        start--;
    }
    /* after sifting down the root all nodes/elements are in heap order */
}


MODULE = Algorithm::Heapify::XS		PACKAGE = Algorithm::Heapify::XS

void
max_heapify(av)
    AV *av
PROTOTYPE: \@
ALIAS:
   max_heapify = 0
   min_heapify = 1
   maxstr_heapify = 2
   minstr_heapify = 3
PREINIT:
    OP fakeop;
    I32 count;
PPCODE:
    FORCE_SCALAR(fakeop);
    count = av_top_index(av)+1;
    if ( count ) {
        heapify_with_sift_down(aTHX_ AvARRAY(av),count,ix);
        ST(0)= AvARRAY(av)[0];
        XSRETURN(1);
    }
    else {
        XSRETURN(0);
    }

void
max_heap_shift(av)
    AV *av
PROTOTYPE: \@
ALIAS:
   max_heap_shift = 0
   min_heap_shift = 1
   maxstr_heap_shift = 2
   minstr_heap_shift = 3
PREINIT:
    OP fakeop;
    I32 top;
    I32 count;
PPCODE:
    FORCE_SCALAR(fakeop);
    top= av_top_index(av);
    count= top+1;
    if (count) {
        SV *tmp= AvARRAY(av)[0];
        AvARRAY(av)[0]= AvARRAY(av)[top];
        AvARRAY(av)[top]= tmp;
        ST(0)= av_pop(av);
        if (count > 2)
            sift_down(aTHX_ AvARRAY(av),0,top-1,ix);
        XSRETURN(1);
    }
    else {
        XSRETURN(0);
    }

void
max_heap_push(av,sv)
    AV *av
    SV *sv
PROTOTYPE: \@$
ALIAS:
   max_heap_push = 0
   min_heap_push = 1
   maxstr_heap_push = 2
   minstr_heap_push = 3
PREINIT:
    OP fakeop;
    I32 top;
    I32 count;
PPCODE:
    FORCE_SCALAR(fakeop);
    av_push(av,newSVsv(sv));
    top= av_top_index(av);
    count= top+1;
    sift_up(aTHX_ AvARRAY(av),0,top,ix);
    ST(0)= AvARRAY(av)[0];
    XSRETURN(1);

void
max_heap_adjust_top(av)
    AV *av
PROTOTYPE: \@
ALIAS:
   max_heap_adjust_top = 0
   min_heap_adjust_top = 1
   maxstr_heap_adjust_top = 2
   minstr_heap_adjust_top = 3
PREINIT:
    OP fakeop;
    I32 top;
    I32 count;
PPCODE:
    FORCE_SCALAR(fakeop);
    top= av_top_index(av);
    count= top+1;
    if ( count ) {
        (void)sift_down(aTHX_ AvARRAY(av),0,top,ix);
        ST(0)= AvARRAY(av)[0];
        XSRETURN(1);
    } else {
        XSRETURN(0);
    }

void
max_heap_adjust_item(av,idx=0)
    AV *av
    I32 idx;
PROTOTYPE: \@;$
ALIAS:
   max_heap_adjust_item = 0
   min_heap_adjust_item = 1
   maxstr_heap_adjust_item = 2
   minstr_heap_adjust_item = 3
PREINIT:
    OP fakeop;
    I32 top;
    I32 count;
PPCODE:
    FORCE_SCALAR(fakeop);
    top= av_top_index(av);
    count= top+1;
    if ( idx < count ) {
        if (!idx || !sift_up(aTHX_ AvARRAY(av),0,idx,ix))
            (void)sift_down(aTHX_ AvARRAY(av),idx,top,ix);
        ST(0)= AvARRAY(av)[0];
        XSRETURN(1);
    } else {
        XSRETURN(0);
    }