Time::HiRes add fast no dTHX; myNVtime() variant for CPAN XS devs (exprmt)

bulk88 · bulk88 · commit ab4ced1d7775 · 2025-06-27T19:51:16.000-04:00
-TMHR has a fancy Perl maintained Win32 high precision GTOD() polyfill impl
 inside it. But it can't be used for actual benchmarking by CPAN authors
 b/c it's do a very slow Perl_get_context() call every time to get access
 to MY_CXT struct. So add a pTHX_ version of myNVtime(). Add tests that
 prove TMHR's C level public API for CPAN authors actually exists and
 works. Nothing inside the P5P repo, ever tries to use TMHR's C level
 Time::HiRes::myNVtime / Time::HiRes::myU2time function pointers.
-The 3 XSUBs for calling the TMHR C func ptrs, really should be in a
 new .xs file inside ext/XS-APItest/ called "benchmark.xs" or
 "noplgetcxt.xs" that has #define NO_PERL_GET_CONTEXT at the top, UNLIKE
 all the other XS-APItest .xs files, which try to prove the very slot
 ithreads-unaware CPAN XS legacy src code compat mode actually works.
-POK and SvPVX() store the 2nd fn ptr, in the same SV*, POK flag can be
 used by CPAN XS authors to separate old TMHR releases w/o the new fn ptr
 from new TMHR releases that have it. NOK and SvNVX() and using
union _xnvu {
    NV	    xnv_nv;
    HV *    xgv_stash; &lt;&lt;&lt;&lt;&lt;&lt;&lt;&lt;
    line_t  xnv_lines;
    bool    xnv_bm_tail;
};
 is an alternative design, but I went with POK and SvPVX, because even with
 SvREADONLY(), I have paranoia, some C code on some OS on some CPU arch
 somewhere, will do a random
     read -&gt; round_and_or_fire_IEEE_OS_signals -&gt; write to SvNVX()
 operation on the SvNVX() slot, for no good reason, b/c of
 academic purity/standards body compliance/ABI requirements of
 that CPU/OS arch, and the function ptr is now giberish, or was converted
 from a denormal NaN to a normal NaN or SIG_DIV0-ed.
-future expansion provision exists, if SvPOK_on &amp;&amp; SvCUR() &gt; sizeof(void*),
 SvPVX() is now a pointer to a C struct/C array, with the 1st 4/8 bytes
 being a header, and not a fn ptr.
-TODO return by copy version of Time::U2time fn ptr, more efficient on
 certain ABIs (__vectorcall/SysV) that allow 128 bit structs/arrays to
 be returned in 2 registers back to the caller, and not secret pointers
 as a secret 1st arg
diff --git a/dist/Time-HiRes/HiRes.xs b/dist/Time-HiRes/HiRes.xs
@@ -671,18 +671,38 @@ myU2time(pTHX_ UV *ret)
     return status;
 }
 
+#ifdef PERL_IMPLICIT_CONTEXT
+static NV myNVtime_cxt(pTHX);
+#endif
+
 static NV
 myNVtime()
 {
 #  ifdef WIN32
     dTHX;
+#    ifdef PERL_IMPLICIT_CONTEXT
+   return myNVtime_cxt(aTHX);
+#    endif
 #  endif
     struct timeval Tp;
     int status;
     status = gettimeofday (&Tp, NULL);
     return status == 0 ? Tp.tv_sec + (Tp.tv_usec / NV_1E6) : -1.0;
 }
 
+#ifdef PERL_IMPLICIT_CONTEXT
+
+static NV
+myNVtime_cxt(pTHX)
+{
+    struct timeval Tp;
+    int status;
+    status = gettimeofday (&Tp, NULL);
+    return status == 0 ? Tp.tv_sec + (Tp.tv_usec / NV_1E6) : -1.0;
+}
+
+#endif
+
 #endif /* #ifdef HAS_GETTIMEOFDAY */
 
 /*  Force inline this because it has only 1 caller:
@@ -1050,9 +1070,26 @@ BOOT:
 #endif
 #ifdef HAS_GETTIMEOFDAY
         {
-            HV* const modglobal = PL_modglobal;
-            (void)hv_stores(modglobal, "Time::NVtime", newSViv(PTR2IV(myNVtime)));
-            (void)hv_stores(modglobal, "Time::U2time", newSViv(PTR2IV(myU2time)));
+            SV* sv = newSV_type(SVt_PVIV);
+#ifdef PERL_IMPLICIT_CONTEXT
+            const static NV (* const pMyNVtime_cxt)(pTHX) = myNVtime_cxt;
+#else
+            const static NV (* const pMyNVtime_cxt)(pTHX) = myNVtime;
+#endif
+/*          Don't bother making a 5/9 byte struct{void*; char;} just for '\0'.
+            It is 8/16 bytes after padding. This SVPV will never be "printed". */
+            SvCUR_set(sv, sizeof(pMyNVtime_cxt));
+            SvLEN_set(sv, 0);
+            SvIV_set(sv, PTR2IV(myNVtime));
+            SvPV_set(sv, (char *)(&pMyNVtime_cxt));
+            SvPOK_on(sv);
+            SvIOK_on(sv);
+            SvREADONLY_on(sv);
+            {
+                HV* const modglobal = PL_modglobal;
+                (void)hv_stores(modglobal, "Time::NVtime", sv);
+                (void)hv_stores(modglobal, "Time::U2time", newSViv(PTR2IV(myU2time)));
+            }
         }
 #endif
 #if defined(PERL_DARWIN)
diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 use Carp;
 
-our $VERSION = '1.42';
+our $VERSION = '1.43';
 
 require XSLoader;
 
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
@@ -1593,6 +1593,121 @@ XSPP_wrapped(my_pp_anonlist, 0, 1)
     RETURN;
 }
 
+static NV (*myNVtime)() = NULL;
+static NV (*myNVtime_cxt)(pTHX) = NULL;
+static void (*myU2time)(pTHX_ UV ret[2]) = NULL;
+
+#if defined(MULTIPLICITY) && !defined(PERL_NO_GET_CONTEXT) && !defined(PERL_CORE)
+#  undef aTHX
+#  undef aTHX_
+#  define aTHX		my_perl
+#  define aTHX_		aTHX,
+#endif
+
+XS_INTERNAL(XS__APItest__XSUB_XS_APIVERSION_Time_HiRes_Init)
+{
+    dVAR; dXSARGS;
+    if (items != 0)
+       croak_xs_usage(cv,  "");
+    PERL_UNUSED_VAR(ax); /* -Wall */
+    {
+        HV* modglobal = PL_modglobal;
+        SV **svp = hv_fetchs(modglobal, "Time::NVtime", 0);
+        SV* sv;
+        if (!svp)
+            croak("Time::HiRes is required");
+        sv = *svp;
+        if (!SvIOK(sv) || !SvIVX(sv))
+            croak("Time::NVtime isn't a function pointer");
+        myNVtime = INT2PTR(NV(*)(), SvIVX(sv));
+        if (!SvPOK(sv) || SvCUR(sv) != sizeof(void*) || SvPVX(sv) == NULL
+            || *((void**)SvPVX(sv)) == NULL)
+            croak("Time::NVtime_cxt isn't a function pointer");
+        else
+            myNVtime_cxt = INT2PTR(NV(*)(pTHX), *((void**)SvPVX(sv)));
+
+        svp = hv_fetchs(modglobal, "Time::U2time", 0);
+        if (!svp)
+            croak("Time::HiRes is required");
+        sv = *svp;
+        if (!SvIOK(sv) || !SvIVX(sv))
+            croak("Time::U2time isn't a function pointer");
+        myU2time = INT2PTR(void(*)(pTHX_ UV ret[2]), SvIVX(sv));
+    }
+    XSRETURN_YES;
+}
+
+XS_INTERNAL(XS__APItest__XSUB_XS_APIVERSION_Time_HiRes_myNVtime)
+{
+    dVAR; dXSARGS;
+    if (items != 0)
+       croak_xs_usage(cv,  "");
+    PERL_UNUSED_VAR(ax); /* -Wall */
+    {
+        dXSTARG;
+        PUSHs(TARG);
+        PUTBACK;
+        {
+            NV nv = myNVtime();
+            TARGn(nv,1);
+        }
+    }
+    return;
+}
+
+XS_INTERNAL(XS__APItest__XSUB_XS_APIVERSION_Time_HiRes_myNVtime_cxt)
+{
+    dVAR; dXSARGS;
+    if (items != 0)
+       croak_xs_usage(cv,  "");
+    PERL_UNUSED_VAR(ax); /* -Wall */
+    {
+        SV* TARG;
+        SV* TARG2;
+        if(GIMME_V != G_LIST) {
+            dXSTARG;
+            TARG2 = TARG;
+        }
+        TARG = TARG2;
+        PUSHs(TARG);
+        PUTBACK;
+        {
+            NV nv = myNVtime_cxt(aTHX);
+            TARGn(nv,1);
+        }
+    }
+    return;
+}
+
+XS_INTERNAL(XS__APItest__XSUB_XS_APIVERSION_Time_HiRes_myU2time)
+{
+    dVAR;
+    dXSARGS;
+    EXTEND(SP, 2);
+    if (items != 0)
+       croak_xs_usage(cv,  "");
+    PERL_UNUSED_VAR(ax); /* -Wall */
+    {
+        dXSTARG;
+        UV ret[2];
+        SV* sv2;
+        PUSHs(TARG);
+        sv2 = sv_2mortal(newSVuv(0));
+        PUSHs(sv2);
+        PUTBACK;
+        myU2time(aTHX_ ret);
+        TARGu(ret[0],1);
+        SvUV_set(sv2, ret[1]);
+    }
+    return;
+}
+
+#if defined(MULTIPLICITY) && !defined(PERL_NO_GET_CONTEXT) && !defined(PERL_CORE)
+#  undef aTHX
+#  undef aTHX_
+#  define aTHX		PERL_GET_THX
+#  define aTHX_		aTHX,
+#endif
 
 #include "const-c.inc"
 
@@ -1873,6 +1988,11 @@ BOOT:
     newXS("XS::APItest::XSUB::XS_VERSION_undef", XS_XS__APItest__XSUB_XS_VERSION_undef, __FILE__);
     newXS("XS::APItest::XSUB::XS_VERSION_empty", XS_XS__APItest__XSUB_XS_VERSION_empty, __FILE__);
     newXS("XS::APItest::XSUB::XS_APIVERSION_invalid", XS_XS__APItest__XSUB_XS_APIVERSION_invalid, __FILE__);
+    newXS("XS::APItest::XSUB::Time::HiRes::Init", XS__APItest__XSUB_XS_APIVERSION_Time_HiRes_Init, __FILE__);
+    newXS("XS::APItest::XSUB::Time::HiRes::myNVtime", XS__APItest__XSUB_XS_APIVERSION_Time_HiRes_myNVtime, __FILE__);
+    newXS("XS::APItest::XSUB::Time::HiRes::myNVtime_cxt", XS__APItest__XSUB_XS_APIVERSION_Time_HiRes_myNVtime_cxt, __FILE__);
+    newXS("XS::APItest::XSUB::Time::HiRes::myU2time", XS__APItest__XSUB_XS_APIVERSION_Time_HiRes_myU2time , __FILE__);
+
 
 void
 XS_VERSION_defined(...)
diff --git a/ext/XS-APItest/t/xsub_h.t b/ext/XS-APItest/t/xsub_h.t
@@ -4,6 +4,7 @@ use strict;
 use Test::More;
 
 BEGIN { use_ok('XS::APItest') };
+BEGIN { use_ok('Time::HiRes') };
 
 our ($XS_VERSION, $VERSION);
 
@@ -150,5 +151,18 @@ is scalar @xs_empty, 0, 'XSRETURN_EMPTY returns empty list in array context';
 my $xs_empty = XS::APItest::XSUB::xsreturn_empty();
 is $xs_empty, undef, 'XSRETURN_EMPTY returns undef in scalar context';
 
+{
+	ok(XS::APItest::XSUB::Time::HiRes::Init(), "XS::APItest::XSUB::Time::HiRes::Init");
+	my $num = XS::APItest::XSUB::Time::HiRes::myNVtime();
+	ok($num && $num != -1.0 &&  int($num) != -1, "XS::APItest::XSUB::Time::HiRes::myNVtime true");
+	$num = XS::APItest::XSUB::Time::HiRes::myNVtime_cxt();
+	ok($num && $num != -1.0 &&  int($num) != -1, "XS::APItest::XSUB::Time::HiRes::myNVtime_cxt true");
+	$num = [XS::APItest::XSUB::Time::HiRes::myU2time()];
+	ok(scalar(@{$num}) == 2, "XS::APItest::XSUB::Time::HiRes::myNVtime_cxt 2 element array");
+	ok($num->[0] && $num->[0] != -1, "XS::APItest::XSUB::Time::HiRes::myNVtime_cxt array[0] true");
+	ok($num->[1] && $num->[1] != -1, "XS::APItest::XSUB::Time::HiRes::myNVtime_cxt array[1] true");
+	ok(!defined($num->[2]), "XS::APItest::XSUB::Time::HiRes::myNVtime_cxt array[2] is undef");
+}
+
 
 done_testing();
