Learning XS - Custom Ops

This is the next tutorial in my Learning XS series. This post explores one of Perl's most powerful optimisation techniques: Custom Ops. We'll build a real-world example, reimplementing one of my first XS cpan modules - a Shannon entropy calculator - and explain how to bypass Perl's subroutine call overhead entirely.

So firstly... What are Custom Ops?

When you call a Perl subroutine, Perl executes an entersub op that:

1. Sets up a new stack frame
2. Pushes arguments onto the stack
3. Magical things happens
4. Jumps to the subroutine code
5. More Magical things can happens
6. Cleans up and returns

For simple functions called millions of times (like mathematical operations), this overhead dominates execution time. Custom ops let you replace the entire entersub call with a single, specialised op - eliminating that overhead.

Next.. What is Shannon Entropy?

Shannon entropy measures the information content (or "randomness") of a string:

• "aaaa" → 0 bits (no randomness, completely predictable)
• "abcd" → 2 bits (4 equally likely symbols = log₂(4))
• Random data → ~8 bits per byte (maximum entropy)

It's used in compression, cryptography, and password strength estimation. A perfect candidate for a small, focused XS module.

In Perl the algorithm for Shannon entropy can look something like:

sub entropy {
    my ($entropy, $len, $p, %t) = (0, length($_[0]));
    $t{$_}++ foreach split '', $_[0];
    foreach (values %t) {
        $p = $_/$len;
        $entropy -= $p * log $p;
    } 
    return $entropy / log 2;
}

Creating the Distribution

First we will need to create a new perl distribution. As we have done in the past we will use Module::Starter.

module-starter --module="Shannon::Entropy::XS" --author="Your Name" --email="your@email.com"

This will create a new directory called Shannon-Entropy-XS with the basic structure of a perl module.

Next we will need to update the Makefile.PL so that it knows we are using XS. One simple way to do this is to add XSMULTI => 1 to the WriteMakefile call. Which will tell MakeMaker to look for XS files in the lib/Shannon/Entropy/ directory.

use ExtUtils::MakeMaker;

my %WriteMakefileArgs = (
    NAME             => 'Shannon::Entropy::XS',
    AUTHOR           => q{Your Name <your@email.com>},
    VERSION_FROM     => 'lib/Shannon/Entropy/XS.pm',
    XSMULTI          => 1,
    LIBS             => [''],
    # ... rest of your config
);

WriteMakefile(%WriteMakefileArgs);

Next lets update the lib/Shannon/Entropy/XS.pm file to load our XS:

package Shannon::Entropy::XS;

use strict;
use warnings;
our $VERSION = '0.01';

require XSLoader;
XSLoader::load("Shannon::Entropy::XS", $VERSION);

use Exporter qw(import);
our @EXPORT_OK = qw(entropy);

1;

Now we can create the XS file. Create a new file called lib/Shannon/Entropy/XS.xs and add the basic structure:

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

MODULE = Shannon::Entropy::XS  PACKAGE = Shannon::Entropy::XS
PROTOTYPES: ENABLE

That defines the package. If we compile this now, the basic tests added by Module::Starter will pass. To test that:

perl Makefile.PL
make test

Adding the Entropy Function

With the basic structure working, lets write a test for our entropy function. Create or update t/01-test.t:

use Test::More;
use strict;
use warnings;
use Shannon::Entropy::XS qw/entropy/;

is(entropy(''), 0);
is(entropy('0'), 0);
is(sprintf('%.3f', entropy('1223334444')), 1.846);
is(entropy('0123456789abcdef'), 4),
is(sprintf('%.3f', entropy('abcdefghijklmnopqrst123456789!@£[]"')), 5.170),

done_testing();

Now we need to implement the entropy calculation. First, add the C helper functions to our XS file, before the MODULE line:

#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include <math.h>

static int makehist(const unsigned char *str, int *hist, int len) {
    int chars[256];
    int histlen = 0, i;
    for (i = 0; i < 256; i++) chars[i] = -1;
    for (i = 0; i < len; i++) {
        int c = (int)str[i];
        if (chars[c] == -1) {
            chars[c] = histlen;
            histlen++;
        }
        hist[chars[c]]++;
    }
    return histlen;
}

static double entropy(const char *str) {
    int len = strlen(str);
    int hist[256] = {0};
    int histlen, i;
    double out = 0.0;
    if (len == 0) return 0.0;
    histlen = makehist((const unsigned char *)str, hist, len);
    for (i = 0; i < histlen; i++) {
        double p = (double)hist[i] / len;
        out -= p * log2(p);
    }
    return out;
}

MODULE = Shannon::Entropy::XS  PACKAGE = Shannon::Entropy::XS
PROTOTYPES: ENABLE

double
entropy(string)
    SV *string
    CODE:
        STRLEN len;
        const char *str = SvPV(string, len);
        RETVAL = entropy(str);
    OUTPUT:
        RETVAL

So what exactly are we doing here? The makehist() function builds a histogram of character frequencies by iterating through the string and mapping each unique character to a slot in the hist array. The chars[256] lookup table tracks which slot each byte value maps to, with -1 meaning "not yet seen". When we encounter a new character, we assign it the next available slot and increment histlen.

The entropy() function then implements the Shannon entropy formula. For each unique character in the histogram, we calculate its probability (count / total length) and accumulate the entropy value. Empty strings return 0 immediately to avoid division by zero.

Finally, the XS wrapper extracts the string from the Perl SV using SvPV() (which gives us both the string pointer and its length) and calls our C function. The result is returned as a double.

Now run make test and our entropy tests should pass. But every call still goes through Perl's entersub op. Let's optimise that with custom ops.

Adding Custom Ops

Custom ops require Perl 5.14+. We'll add three pieces:

1. An XOP structure (for debugging/introspection)
2. A PP function (the actual operation)
3. A call checker (transforms the op tree at compile time)

First we need to add some back porting as part of the API we are about to use was introduced in 5.26, after the last import add:

#ifndef OpSIBLING
#  define OpSIBLING(o)              ((o)->op_sibling)
#endif
#ifndef OpMORESIB_set
#  define OpMORESIB_set(o, sib)     ((o)->op_sibling = (sib))
#endif
#ifndef OpLASTSIB_set
#  define OpLASTSIB_set(o, parent)  ((o)->op_sibling = NULL)
#endif

Next, we can add the XOP declaration after the last endif from above add:

#if PERL_VERSION >= 14
static XOP entropy_xop;
#endif

The XOP (eXtended OP) structure provides metadata - the op's name and description that appear in tools like B::Concise.

The PP Function

Every Perl op has a "pp" (push-pop) function that does the actual work. Add this after your entropy functions, inside a #if PERL_VERSION >= 14 block:

#if PERL_VERSION >= 14

static OP* pp_entropy(pTHX) {
    dSP;
    SV *sv = TOPs;
    STRLEN len;
    const char *str = SvPV(sv, len);
    double result = entropy(str);
    POPs;
    mPUSHn(result);
    RETURN;
}

#endif

A line by line explanation of the above code:

1. dSP - Declares the stack pointer local variable
2. SV *sv = TOPs - Gets the top of stack (our argument) without popping it
3. SvPV(sv, len) - Extracts the string and its length
4. entropy(str) - Calls our C function
5. POPs - Pops the argument off the stack
6. mPUSHn(result) - Pushes the result as a mortal (auto-freed) numeric value
7. RETURN - Returns control to the next op in the chain

The Call Checker

This is where the real magic happens. A call checker is invoked at compile time when Perl sees a call to our function. We can inspect the op tree and transform it. Add this after the pp function:

static OP* entropy_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
    OP *pushop, *argop, *nextop, *newop;
    PERL_UNUSED_ARG(namegv);
    PERL_UNUSED_ARG(ckobj);

    pushop = cLISTOPx(entersubop)->op_first;
    if (!pushop) return entersubop;

    /* Handle null op wrapper in modern Perl */
    if (pushop->op_type == OP_NULL && cLISTOPx(pushop)->op_first) {
        pushop = cLISTOPx(pushop)->op_first;
    }

    argop = OpSIBLING(pushop);
    if (!argop) return entersubop;

    nextop = OpSIBLING(argop);
    if (!nextop) return entersubop;

    if (OpSIBLING(nextop)) return entersubop;

    OpMORESIB_set(pushop, nextop);
    OpLASTSIB_set(argop, NULL);
    newop = newUNOP(OP_CUSTOM, 0, argop);
    newop->op_ppaddr = pp_entropy;
    op_free(entersubop);
    return newop;
}

#endif

So what is actually happening here? The call checker receives the entersub op that Perl normally uses to call subroutines. Inside an entersub, the child ops form a linked list: pushmark -> arg1 -> arg2 -> ... -> cv. We use cLISTOPx(entersubop)->op_first to get the first child. In modern Perl (5.22+), this is often wrapped in a null op, so we check for that and unwrap it to find the actual pushmark. Then we use OpSIBLING() to navigate to our argument.

Before we do anything destructive, we validate that the call matches our expected signature. The series of null checks and the OpSIBLING(nextop) test ensure we have exactly one argument. If someone called entropy($a, $b) with two arguments, or used the &entropy sigil syntax, we bail out early by returning entersubop unchanged - Perl falls back to the normal subroutine call mechanism.

Once we've validated the call, we surgically detach the argument op from the entersub's child list. OpMORESIB_set(pushop, nextop) rewires pushmark to skip over our argument, linking it directly to the CV. OpLASTSIB_set(argop, NULL) disconnects argop from its siblings entirely, leaving it as a standalone op.

With the argument detached, we create our custom op using newUNOP(OP_CUSTOM, 0, argop). This creates a unary op with our argument as its child. We then assign our pp function to execute when this op runs: newop->op_ppaddr = pp_entropy. Finally, we free the original entersub with op_free() since it's no longer needed, and return our shiny new custom op to take its place in the op tree.

Wiring It Up in BOOT

The BOOT section runs when the module loads. We register our custom op and install the call checker. Add this after your XS entropy function:

BOOT:
#if PERL_VERSION >= 14
{
    CV *entropy_cv;
    XopENTRY_set(&entropy_xop, xop_name, "entropy");
    XopENTRY_set(&entropy_xop, xop_desc, "Shannon entropy calculation");
    Perl_custom_op_register(aTHX_ pp_entropy, &entropy_xop);
    entropy_cv = get_cv("Shannon::Entropy::XS::entropy", 0);
    if (entropy_cv) {
        cv_set_call_checker(entropy_cv, entropy_call_checker, (SV *)entropy_cv);
    }
}
#endif

The first thing we do is set up the XOP metadata using XopENTRY_set(). This registers the name "entropy" and a description "Shannon entropy calculation" with our custom op. These strings appear in debugging tools like B::Concise and Devel::Peek, making it much easier to understand op trees when things do go wrong.

Next, Perl_custom_op_register() connects our pp function to the XOP structure. This tells Perl's introspection system that whenever it encounters an OP_CUSTOM with our pp_entropy address, it should use our XOP metadata for display purposes.

Finally, we wire up the call checker itself. get_cv() retrieves the CV (code value) for our Shannon::Entropy::XS::entropy function - this is the subroutine object that Perl created when it compiled the XSUB. We then call cv_set_call_checker() to install our call checker on that CV. From now on, whenever Perl compiles a call to entropy(), it will invoke our entropy_call_checker function, giving us the chance to transform the op tree.

Now run make clean && make test and all tests should still pass - but now with custom ops!

Verifying It Works

You can use B::Concise to see the optimised op tree. Create a simple test script:

use B::Concise;
use Shannon::Entropy::XS qw(entropy);

B::Concise::compile('-exec', sub { entropy("test") })->();

Without custom ops, you'd see entersub. With them, you'll see our entropy custom op directly in the tree - proof that we've eliminated the subroutine call overhead!

B::Concise::compile(CODE(0x12b02b4f0))
1  <;> nextstate(main 1816 test.pl:4) v
2  <$> const[PV "test"] s
3  <0> entropy K/1
4  <1> leavesub[1 ref] K/REFC,1

Okay at this point you may or may not be asking why you would replace 9 lines of code with 111 lines... well it would be for the performance improvement you've just achieved. Take this quick benchmark as justification:

Benchmark: Short string (5 chars)
----------------------------------------
                           Rate     Shannon::Entropy Shannon::Entropy::XS
Shannon::Entropy       908579/s                   --                 -95%
Shannon::Entropy::XS 18023002/s                1884%                   --

Benchmark: Medium string (43 chars)
----------------------------------------
                          Rate     Shannon::Entropy Shannon::Entropy::XS
Shannon::Entropy      165257/s                   --                 -98%
Shannon::Entropy::XS 8525479/s                5059%                   -- 

Extension: Alternative Approaches to Custom Ops

So far we've covered what I consider the proper way to implement custom ops. But you may encounter other patterns in existing code, and it's worth understanding why some approaches are better than others.

The Proper Way (What We Did)

Our call checker restructures the op tree properly:

1. Detaches arguments from the entersub
2. Creates a new OP_CUSTOM unop
3. Frees the old entersub entirely

newop = newUNOP(OP_CUSTOM, 0, argop);
newop->op_ppaddr = pp_entropy;
op_free(entersubop);
return newop;

This is more code, but it's correct. The op tree is clean, B::Concise shows your custom op, and it works in all contexts.

The Quick Hack (Avoid This)

Some other modules take a shortcut - they just swap the op_ppaddr pointer without restructuring the tree:

static OP* hack_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *protosv) {
    PERL_UNUSED_ARG(namegv);
    PERL_UNUSED_ARG(protosv);
    entersubop->op_ppaddr = my_custom_op;
    return entersubop;  /* Return unchanged! */
}

The problem is that your pp function now has to deal with the entersub's stack frame, using TOPMARK/POPMARK manipulation:

static OP* my_custom_op(pTHX) {
    dSP;
    I32 ax = TOPMARK + 1;
    I32 items = (SP - PL_stack_base - TOPMARK) - 1;
    if (items < 1) croak("requires at least 1 argument");
    SV *sv = PL_stack_base[ax];
    /* ... do work ... */
    SP = PL_stack_base + POPMARK;
    EXTEND(SP, 1);
    PUSHs(newSVnv(result));  /* Memory leak! */
    PUTBACK;
    return NORMAL;
}

Why avoid this?

• Fragile - Breaks when your function is called inside other expressions
• Memory leaks - Easy to forget mortalization (note newSVnv() above leaks!)
• Debugging confusion - B::Concise still shows entersub, not your custom op
• Complex code - The pp function is harder to understand and maintain

Shared Call Checker (For Multiple Functions)

If you're building a library with many similar functions (like a maths library), you can use a generic call checker that takes a function pointer:

static OP* vec_unary_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj, OP* (*pp_func)(pTHX)) {
    OP *pushop, *selfop, *nextop, *newop;
    PERL_UNUSED_ARG(namegv);
    PERL_UNUSED_ARG(ckobj);

    pushop = cUNOPx(entersubop)->op_first;
    if (!OpHAS_SIBLING(pushop)) return entersubop;

    selfop = OpSIBLING(pushop);
    if (!selfop) return entersubop;

    nextop = OpSIBLING(selfop);
    if (!nextop) return entersubop;

    if (OpSIBLING(nextop)) return entersubop;

    OpMORESIB_set(pushop, nextop);
    OpLASTSIB_set(selfop, NULL);

    newop = newUNOP(OP_CUSTOM, 0, selfop);
    newop->op_ppaddr = pp_func;
    op_free(entersubop);
    return newop;
}

Then create thin wrappers for each function:

static OP* vec_sum_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
    return vec_unary_call_checker(aTHX_ entersubop, namegv, ckobj, pp_vec_sum);
}

static OP* vec_mean_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
    return vec_unary_call_checker(aTHX_ entersubop, namegv, ckobj, pp_vec_mean);
}

static OP* vec_min_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
    return vec_unary_call_checker(aTHX_ entersubop, namegv, ckobj, pp_vec_min);
}

This keeps your code DRY while still doing proper op tree restructuring.

Binary Ops (Two Arguments)

For functions taking two arguments, use newBINOP instead of newUNOP:

static OP* binary_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
    OP *pushop, *arg1, *arg2, *nextop, *newop;
    PERL_UNUSED_ARG(namegv);
    PERL_UNUSED_ARG(ckobj);

    pushop = cUNOPx(entersubop)->op_first;
    if (!OpHAS_SIBLING(pushop)) return entersubop;

    arg1 = OpSIBLING(pushop);
    if (!arg1) return entersubop;

    arg2 = OpSIBLING(arg1);
    if (!arg2) return entersubop;

    nextop = OpSIBLING(arg2);
    if (!nextop) return entersubop;

    if (OpSIBLING(nextop)) return entersubop;

    OpMORESIB_set(pushop, nextop);
    OpLASTSIB_set(arg1, NULL);
    OpLASTSIB_set(arg2, NULL);

    newop = newBINOP(OP_CUSTOM, 0, arg1, arg2);
    newop->op_ppaddr = pp_my_binary_func;
    op_free(entersubop);
    return newop;
}

The pp function for a binary op pops two values:

static OP* pp_my_binary_func(pTHX) {
    dSP;
    SV *right = POPs;
    SV *left = POPs;
    /* combine left and right */
    mPUSHn(result);
    RETURN;
}

If you have any further questions then please do post them below.