Algorithm-AM
view release on metacpan or search on metacpan
}
}
/*
* This function is called by from AM.pm right after creating
* a blessed reference to Algorithm::AM. It stores the necessary
* pointers in the AM_GUTS structure and attaches it to the magic
* part of the reference.
*
*/
void
_xs_initialize(...)
PPCODE:
/* NOT A POINTER THIS TIME! (let memory allocate automatically) */
AM_GUTS guts;
/* 9 arguments are passed to the _xs_initialize method: */
/* $self, the AM object */
HV *self = hash_pointer_from_stack(0);
/* For explanations on these, see the comments on AM_guts */
SV **lattice_sizes = array_pointer_from_stack(1);
guts.classes = array_pointer_from_stack(2);
guts.itemcontextchain = array_pointer_from_stack(3);
guts.itemcontextchainhead = hash_pointer_from_stack(4);
guts.context_to_class = hash_pointer_from_stack(5);
guts.context_size = hash_pointer_from_stack(6);
guts.pointers = hash_pointer_from_stack(7);
guts.raw_gang = hash_pointer_from_stack(8);
guts.sum = array_pointer_from_stack(9);
/* Length of guts.sum */
guts.num_classes = av_len((AV *) SvRV(ST(9)));
/*
* Since the sublattices are small, we just take a chunk of memory
* here that will be large enough for our purposes and do the actual
* memory allocation within the code; this reduces the overhead of
* repeated system calls.
*
*/
for (int i = 0; i < NUM_LATTICES; ++i) {
UV v = SvUVX(lattice_sizes[i]);
Newxz(guts.lattice_list[i], 1 << v, AM_SHORT);
Newxz(guts.supra_list[i], 1 << (v + 1), AM_SUPRA); /* CHANGED */ /* TODO: what changed? */
Newxz(guts.supra_list[i][0].data, 2, AM_SHORT);
}
/* Perl magic invoked here */
SV *svguts = newSVpv((char *)&guts, sizeof(AM_GUTS));
sv_magic((SV *) self, svguts, PERL_MAGIC_ext, NULL, 0);
SvRMAGICAL_off((SV *) self);
MAGIC *magic = mg_find((SV *)self, PERL_MAGIC_ext);
magic->mg_virtual = &AMguts_vtab;
mg_magical((SV *) self);
void
_fillandcount(...)
PPCODE:
/* Input args are the AM object ($self), number of features in each
* lattice, and a flag to indicate whether to count occurrences
* (true) or pointers (false), also known as linear/quadratic.
*/
HV *self = hash_pointer_from_stack(0);
SV **lattice_sizes_input = array_pointer_from_stack(1);
UV linear_flag = unsigned_int_from_stack(2);
MAGIC *magic = mg_find((SV *)self, PERL_MAGIC_ext);
AM_GUTS *guts = (AM_GUTS *)SvPVX(magic->mg_obj);
/*
* We initialize the memory for the sublattices, including setting up the
* linked lists.
*/
AM_SHORT **lattice_list = guts->lattice_list;
AM_SUPRA **supra_list = guts->supra_list;
/* this helps us manage the free list in supra_list[i] */
AM_SHORT nptr[NUM_LATTICES];
AM_SHORT lattice_sizes[NUM_LATTICES];
for (int sublattice_index = 0; sublattice_index < NUM_LATTICES; ++sublattice_index) {
/* Extract numeric values for the specified lattice_sizes */
lattice_sizes[sublattice_index] = (AM_SHORT) SvUVX(lattice_sizes_input[sublattice_index]);
/* TODO: explain the lines below */
Zero(lattice_list[sublattice_index], 1 << lattice_sizes[sublattice_index], AM_SHORT);
supra_list[sublattice_index][0].next = 0;
nptr[sublattice_index] = 1;
for (int i = 1; i < 1 << (lattice_sizes[sublattice_index] + 1); ++i) {/* CHANGED (TODO: changed what?) */
supra_list[sublattice_index][i].next = (AM_SHORT) i + 1;
}
}
/*
* Instead of adding subcontext labels directly to the supracontexts,
* we store all of these labels in an array called subcontext. We
* then store the array indices of the subcontext labels in the
* supracontexts. That means the list of subcontexts in the
* supracontexts is an increasing sequence of positive integers, handy
* for taking intersections (see lattice.pod).
*
* The index into the array is called subcontextnumber.
*
* The array of matching classes is called subcontext_class.
*
*/
HV *context_to_class = guts->context_to_class;
AM_SHORT subcontextnumber = (AM_SHORT)HvUSEDKEYS(context_to_class);
AM_SHORT *subcontext;
Newxz(subcontext, NUM_LATTICES *(subcontextnumber + 1), AM_SHORT);
subcontext += NUM_LATTICES * subcontextnumber;
AM_SHORT *subcontext_class;
Newxz(subcontext_class, subcontextnumber + 1, AM_SHORT);
subcontext_class += subcontextnumber;
AM_SHORT *intersectlist, *intersectlist2, *intersectlist3;
AM_SHORT *ilist2top, *ilist3top;
Newxz(intersectlist, subcontextnumber + 1, AM_SHORT);
Newxz(intersectlist2, subcontextnumber + 1, AM_SHORT);
ilist2top = intersectlist2 + subcontextnumber;
Newxz(intersectlist3, subcontextnumber + 1, AM_SHORT);
ilist3top = intersectlist3 + subcontextnumber;
hv_iterinit(context_to_class);
HE *context_to_class_entry;
while ((context_to_class_entry = hv_iternext(context_to_class))) {
AM_SHORT *contextptr = (AM_SHORT *) HeKEY(context_to_class_entry);
/* Find intersection between p0 and p1 */
AM_SHORT *k = intersect_supras(
sublist_top(p0),
sublist_top(p1),
ilist2top
);
/* If k has not been increased then intersection was empty */
if (k == ilist2top) {
continue;
}
*k = 0;
AM_SUPRA *p2;
for (iter_supras(p2, supra_list[2])) {
/*Find intersection between previous intersection and p2*/
k = intersect_supras(
ilist2top,
sublist_top(p2),
ilist3top
);
/* If k has not been increased then intersection was empty */
if (k == ilist3top) {
continue;
}
*k = 0;
AM_SUPRA *p3;
for (iter_supras(p3, supra_list[3])) {
/* Find intersection between previous intersection and p3;
* check for disqualified supras this time.
*/
AM_SHORT length = intersect_supras_final(
ilist3top,
sublist_top(p3),
intersectlist,
subcontext_class
);
/* count occurrences */
if (length) {
AM_BIG_INT count = {0, 0, 0, 0, 0, 0, 0, 0};
count[0] = p0->count;
count[0] *= p1->count;
carry(count, 0);
count[0] *= p2->count;
count[1] *= p2->count;
carry(count, 0);
carry(count, 1);
count[0] *= p3->count;
count[1] *= p3->count;
count[2] *= p3->count;
carry(count, 0);
carry(count, 1);
carry(count, 2);
if(!linear_flag){
/* If scoring is pointers (quadratic) instead of linear*/
AM_LONG pointercount = 0;
for (int i = 0; i < length; ++i) {
pointercount += (AM_LONG) SvUV(*hv_fetch(context_size,
(char *) (subcontext + (NUM_LATTICES * intersectlist[i])), 8, 0));
}
if (pointercount & 0xffff0000) {
AM_SHORT pchi = (AM_SHORT) (high_bits(pointercount));
AM_SHORT pclo = (AM_SHORT) (low_bits(pointercount));
AM_LONG hiprod[6];
hiprod[1] = pchi * count[0];
hiprod[2] = pchi * count[1];
hiprod[3] = pchi * count[2];
hiprod[4] = pchi * count[3];
count[0] *= pclo;
count[1] *= pclo;
count[2] *= pclo;
count[3] *= pclo;
carry(count, 0);
carry(count, 1);
carry(count, 2);
carry(count, 3);
count[1] += hiprod[1];
count[2] += hiprod[2];
count[3] += hiprod[3];
count[4] += hiprod[4];
carry(count, 1);
carry(count, 2);
carry(count, 3);
carry(count, 4);
} else {
count[0] *= pointercount;
count[1] *= pointercount;
count[2] *= pointercount;
count[3] *= pointercount;
carry(count, 0);
carry(count, 1);
carry(count, 2);
carry(count, 3);
}
}
for (int i = 0; i < length; ++i) {
SV *final_pointers_sv = *hv_fetch(pointers,
(char *) (subcontext + (NUM_LATTICES * intersectlist[i])), 8, 1);
if (!SvPOK(final_pointers_sv)) {
SvUPGRADE(final_pointers_sv, SVt_PVNV);
SvGROW(final_pointers_sv, 8 * sizeof(AM_LONG) + 1);
Zero(SvPVX(final_pointers_sv), 8, AM_LONG);
SvCUR_set(final_pointers_sv, 8 * sizeof(AM_LONG));
SvPOK_on(final_pointers_sv);
}
AM_LONG *final_pointers = (AM_LONG *) SvPVX(final_pointers_sv);
for (int j = 0; j < 7; ++j) {
*(final_pointers + j) += count[j];
carry_pointer(final_pointers + j);
}
} /* end for (i = 0;... */
} /* end if (length) */
} /* end for (iter_supras(p3... */
( run in 0.435 second using v1.01-cache-2.11-cpan-e1769b4cff6 )