From: Vincent Pit <vince@profvince.com>
Date: Fri, 8 Aug 2008 14:11:27 +0000 (+0200)
Subject: Rewrite combine in XS
X-Git-Tag: v0.03~14
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FSub-Nary.git;a=commitdiff_plain;h=91deeda20173f3d35c5b936c9e6db1cbe08f0e00

Rewrite combine in XS
---

diff --git a/MANIFEST b/MANIFEST
index 97be8af..37e7c29 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -10,6 +10,7 @@ t/02-can.t
 t/10-obj.t
 t/11-cache.t
 t/15-scalops.t
+t/16-combine.t
 t/20-return.t
 t/21-list.t
 t/22-call.t
diff --git a/Nary.xs b/Nary.xs
index 116040c..75892ce 100644
--- a/Nary.xs
+++ b/Nary.xs
@@ -10,17 +10,29 @@
 # define mPUSHi(I) PUSHs(sv_2mortal(newSViv(I)))
 #endif /* !mPUSHi */
 
+typedef struct {
+ UV k;
+ NV v;
+} sn_combcache;
+
+STATIC U32 sn_hash_list = 0;
+
 /* --- XS ------------------------------------------------------------------ */
 
 MODULE = Sub::Nary            PACKAGE = Sub::Nary
 
 PROTOTYPES: ENABLE
 
+BOOT:
+{
+ PERL_HASH(sn_hash_list, "list", 4);
+}
+
 void
 tag(SV *op)
 PROTOTYPE: $
 CODE:
- ST(0) = sv_2mortal(newSVuv(SvIV(SvRV(op))));
+ ST(0) = sv_2mortal(newSVuv(SvUV(SvRV(op))));
  XSRETURN(1);
 
 void
@@ -29,7 +41,7 @@ PROTOTYPE: $
 PREINIT:
  OP *o;
 CODE:
- o = INT2PTR(OP *, SvIV(SvRV(op)));
+ o = INT2PTR(OP *, SvUV(SvRV(op)));
  ST(0) = sv_2mortal(newSVuv(o == NULL));
  XSRETURN(1);
 
@@ -102,6 +114,7 @@ CODE:
   val = newSVuv(1);
   if (!hv_store_ent(res, sv, val, 0)) {
    SvREFCNT_dec(val);
+   SvREFCNT_dec(res);
    XSRETURN_UNDEF;
   }
  } else {
@@ -110,6 +123,7 @@ CODE:
    val = newSVuv(1);
    if (!hv_store(res, "0", 1, val, 0)) {
     SvREFCNT_dec(val);
+    SvREFCNT_dec(res);
     XSRETURN_UNDEF;
    }
   } else {
@@ -127,6 +141,164 @@ CODE:
  ST(0) = sv_2mortal(newRV_noinc((SV *) res));
  XSRETURN(1);
 
+void
+combine(...)
+PROTOTYPE: @
+PREINIT:
+ HV *res[2];
+ SV *cur, *val;
+ SV *list1, *list2;
+ SV *temp;
+ HE *key, *old;
+ I32 i;
+ I32 n = 0, o;
+ I32 j, n1, n2;
+ UV shift = 0, do_shift = 0;
+ sn_combcache *cache = NULL;
+ I32 cachelen = 0;
+CODE:
+ if (!items)
+  XSRETURN_UNDEF;
+ res[0] = res[1] = NULL;
+ for (i = 0; i < items; ++i) {
+  cur = ST(i);
+  if (!SvOK(cur)) 
+   continue;
+  if (!SvROK(cur)) {
+   if (strEQ(SvPV_nolen(cur), "list")) {
+    res[0] = newHV();
+    n      = 0;
+    val    = newSVuv(1);
+    if (!hv_store(res[0], "list", 4, val, sn_hash_list))
+     SvREFCNT_dec(val);
+    i = items;
+    if (!shift)
+     do_shift = 0;
+    break;
+   } else {
+    shift += SvUV(cur);
+    do_shift = 1;
+    continue;
+   }
+  }
+  cur    = SvRV(cur);
+  res[0] = newHV();
+  while (key = hv_iternext((HV *) cur)) {
+   val = newSVsv(HeVAL(key));
+   if (!hv_store_ent(res[0], HeSVKEY_force(key), val, 0))
+    SvREFCNT_dec(val);
+  }
+  n = 0;
+  if (!shift)
+   do_shift = 0;
+  break;
+ }
+ temp = sv_2mortal(newSViv(0));
+ for (++i; i < items; ++i) {
+  cur = ST(i);
+  if (!SvOK(cur))
+   continue;
+  if (!SvROK(cur)) {
+   if (strEQ(SvPV_nolen(cur), "list")) {
+    hv_clear(res[n]);
+    val = newSVuv(1);
+    if (!hv_store(res[n], "list", 4, val, sn_hash_list))
+     SvREFCNT_dec(val);
+    shift = 0;
+    do_shift = 0;
+    break;
+   } else {
+    shift += SvUV(cur);
+    continue;
+   }
+  }
+  cur = SvRV(cur);
+  o   = 1 - n;
+  if (!res[o])
+   res[o] = newHV();
+  else
+   hv_clear(res[o]);
+  list1 = hv_delete((HV *) cur, "list", 4, 0);
+  n1    = hv_iterinit((HV *) cur);
+  list2 = hv_delete(res[n],     "list", 4, 0);
+  n2    = hv_iterinit(res[n]);
+  if ((list1 && !n1) || (list2 && !n2)) {
+   val = newSViv(1);
+   if (!hv_store(res[o], "list", 4, val, sn_hash_list))
+    SvREFCNT_dec(val);
+   n = o;
+   break;
+  } else if (list1 || list2) {
+   NV l1 = list1 ? SvNV(list1) : 0;
+   NV l2 = list2 ? SvNV(list2) : 0;
+   val = newSVnv(l1 + l2 - l1 * l2);
+   if (!hv_store(res[o], "list", 4, val, sn_hash_list))
+    SvREFCNT_dec(val);
+  }
+  if (n2 > cachelen) {
+   Renew(cache, n2, sn_combcache);
+   cachelen = n2;
+  }
+  j = 0;
+  while (key = hv_iternext(res[n])) {
+   cache[j].k = SvUV(HeSVKEY_force(key));
+   cache[j].v = SvNV(HeVAL(key));
+   ++j;
+  }
+  while (key = hv_iternext((HV *) cur)) {
+   IV k = SvUV(HeSVKEY_force(key));
+   NV v = SvNV(HeVAL(key));
+   for (j = 0; j < n2; ++j) {
+    sv_setiv(temp, k + cache[j].k);
+    if ((old = hv_fetch_ent(res[o], temp, 1, 0)) && SvOK(val = HeVAL(old))) {
+     val = newSVnv(SvNV(val) + v * cache[j].v);
+    } else {
+     val = newSVnv(v * cache[j].v);
+    }
+    if (!hv_store_ent(res[o], temp, val, 0))
+     SvREFCNT_dec(val);
+   }
+  }
+  n = o;
+ }
+ Safefree(cache);
+ if (shift || do_shift) {
+  if (!res[n]) {
+   res[n] = newHV();
+   sv_setiv(temp, shift);
+   val = newSViv(1);
+   if (!hv_store_ent(res[n], temp, val, 0))
+    SvREFCNT_dec(val);
+  } else {
+   o = 1 - n;
+   if (!res[o])
+    res[o] = newHV();
+   else
+    hv_clear(res[o]);
+   list1 = hv_delete(res[n], "list", 4, 0);
+   hv_iterinit(res[n]);
+   while (key = hv_iternext(res[n])) {
+    sv_setiv(temp, SvUV(HeSVKEY_force(key)) + shift);
+    val = newSVsv(HeVAL(key));
+    if (!hv_store_ent(res[o], temp, val, 0))
+     SvREFCNT_dec(val);
+   }
+   if (list1) {
+    val = newSVsv(list1);
+    if (!hv_store(res[o], "list", 4, val, sn_hash_list))
+     SvREFCNT_dec(val);
+   }
+   n = o;
+  }
+ } else if (!res[0] && !res[1])
+  XSRETURN_UNDEF;
+ if (n == 1)
+  SvREFCNT_dec(res[0]);
+ else if (res[1]) 
+  SvREFCNT_dec(res[1]);
+ ST(0) = sv_2mortal(newRV_noinc((SV *) res[n]));
+ XSRETURN(1);
+
 void
 scalops()
 PROTOTYPE:
diff --git a/lib/Sub/Nary.pm b/lib/Sub/Nary.pm
index bda8335..f21c8f8 100644
--- a/lib/Sub/Nary.pm
+++ b/lib/Sub/Nary.pm
@@ -184,27 +184,6 @@ sub scale {
  return (ref $r) ? { map { $_ => $r->{$_} * $c } keys %$r } : { $r => $c };
 }
 
-sub combine {
- reduce {{
-  my %res;
-  my $la = delete $a->{list};
-  my $lb = delete $b->{list};
-  if (defined $la || defined $lb) {
-   $la ||= 0;
-   $lb ||= 0;
-   $res{list} = $la + $lb - $la * $lb;
-  }
-  while (my ($ka, $va) = each %$a) {
-   $ka = int $ka;
-   while (my ($kb, $vb) = each %$b) {
-    my $key = $ka + int $kb;
-    $res{$key} += $va * $vb;
-   }
-  }
-  \%res
- }} map { (ref) ? $_ : { $_ => 1 } } grep defined, @_;
-}
-
 sub power {
  my ($p, $n, $c) = @_;
  return unless defined $p;
diff --git a/t/16-combine.t b/t/16-combine.t
new file mode 100644
index 0000000..03b8386
--- /dev/null
+++ b/t/16-combine.t
@@ -0,0 +1,51 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 24;
+
+use Sub::Nary;
+
+*combine = *Sub::Nary::combine{CODE};
+
+my $h12 = { 1 => 0.5, 2 => 0.5 };
+
+my @tests = (
+ [ [ ],       undef ],
+ [ [ undef ], undef ],
+
+ [ [ 0 ],                0 ],
+ [ [ 1, undef ],         1 ],
+ [ [ undef, 2 ],         2 ],
+ [ [ 0, 1 ],             1 ],
+ [ [ 1, 2 ],             3 ],
+ [ [ 2, undef, 3 ],      5 ],
+
+ [ [ 'list' ],       'list' ],
+ [ [ 0, 'list' ],        'list' ],
+ [ [ 1, 'list' ],        'list' ],
+ [ [ 1, undef, 'list' ], 'list' ],
+ [ [ 1, 'list', 2 ],     'list' ],
+
+ [ [ $h12 ],             $h12 ],
+ [ [ 1, $h12 ],          { 2 => 0.5, 3 => 0.5 } ],
+ [ [ $h12, 2 ],          { 3 => 0.5, 4 => 0.5 } ],
+ [ [ $h12, undef, 3 ],   { 4 => 0.5, 5 => 0.5 } ],
+ [ [ $h12, 'list' ],     'list' ],
+ [ [ $h12, 3, 'list' ],  'list' ],
+ [ [ 1, 0, $h12, 2, 0 ], { 4 => 0.5, 5 => 0.5 } ],
+
+ [ [ $h12, $h12 ],       { 2 => 0.25, 3 => 0.5, 4 => 0.25 } ],
+ [ [ 1, $h12, $h12 ],    { 3 => 0.25, 4 => 0.5, 5 => 0.25 } ],
+ [ [ $h12, 2, $h12 ],    { 4 => 0.25, 5 => 0.5, 6 => 0.25 } ],
+ [ [ $h12, $h12, 3 ],    { 5 => 0.25, 6 => 0.5, 7 => 0.25 } ],
+);
+
+my $i = 1;
+for (@tests) {
+ my $r = combine(@{$_->[0]});
+ my $exp = (not defined $_->[1] or ref $_->[1]) ? $_->[1] : { $_->[1] => 1 };
+ is_deeply($r, $exp, 'combine test ' . $i);
+ ++$i;
+}