XS and XSUBs

• way of adding C subroutines to Perl
• calling C from Perl is really messy (see below).
• XS: a way to make incorporating C bearable.
• Actually, a macro processor much like assignment 3!

XS

• Simplified syntax for mixing C and Perl
• file.xs: XSUB declaration file
  • beginning of file is C
  • after MODULE directive, remainder is XSUB language.
• Example:

  contents of perl_xs/Mytest/Mytest.xs...
  #include "EXTERN.h"
  #include "perl.h"
  #include "XSUB.h"
  
  #include "math.h" 	/* couch added this one */ 
  
  MODULE = Mytest		PACKAGE = Mytest		
  
  void
  hello()
      INPUT: 
      CODE:
         printf("ok 1\n");
      OUTPUT: 
  
  int 
  is_even(x)
      INPUT: 
  	int x
      CODE: 
          RETVAL = (x%2==0); 
      OUTPUT: 
          RETVAL
  
  void
  round(arg)
      INPUT: 
  	double arg
      CODE: 
  	if (arg>0.0) { 
              arg=floor(arg+0.5); 
  	} else if (arg<0.0) { 
  	    arg=ceil(arg-0.5); 
          } else { 
  	    arg=0.0; 
          } 
      OUTPUT: 
          arg
  ...end of perl_xs/Mytest/Mytest.xs
  

Creating an XS module

• cd to a directory to contain the module
• use h2xs to create a template for the module

   h2xs -A -n Mytest
  

  This creates a directory Mytest containing:
• Mytest.xs (as above): template for XSUB language.
• Mytest.pm: template for module that loads C extension:

  contents of perl_xs/Mytest/Mytest.pm...
  package Mytest;
  
  use 5.006;
  use strict;
  use warnings;
  
  require Exporter;
  require DynaLoader;
  
  our @ISA = qw(Exporter DynaLoader);
  
  # Items to export into callers namespace by default. Note: do not export
  # names by default without a very good reason. Use EXPORT_OK instead.
  # Do not simply export all your public functions/methods/constants.
  
  # This allows declaration	use Mytest ':all';
  # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
  # will save memory.
  our %EXPORT_TAGS = ( 'all' => [ qw(
  	
  ) ] );
  
  our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
  
  our @EXPORT = qw(
  	
  );
  our $VERSION = '0.01';
  
  bootstrap Mytest $VERSION;
  
  # Preloaded methods go here.
  
  1;
  __END__
  # Below is stub documentation for your module. You better edit it!
  
  =head1 NAME
  
  Mytest - Perl extension for blah blah blah
  
  =head1 SYNOPSIS
  
    use Mytest;
    blah blah blah
  
  =head1 DESCRIPTION
  
  Stub documentation for Mytest, created by h2xs. It looks like the
  author of the extension was negligent enough to leave the stub
  unedited.
  
  Blah blah blah.
  
  =head2 EXPORT
  
  None by default.
  
  
  =head1 AUTHOR
  
  A. U. Thor, E<lt>a.u.thor@a.galaxy.far.far.awayE<gt>
  
  =head1 SEE ALSO
  
  L<perl>.
  
  =cut
  ...end of perl_xs/Mytest/Mytest.pm
  

  In this file, the bootstrap line is the line that actually loads the C extension.
• Makefile.PL: how to create a Makefile for the project:

  contents of perl_xs/Mytest/Makefile.PL...
  use ExtUtils::MakeMaker;
  # See lib/ExtUtils/MakeMaker.pm for details of how to influence
  # the contents of the Makefile that is written.
  WriteMakefile(
      'NAME'		=> 'Mytest',
      'VERSION_FROM'	=> 'Mytest.pm', # finds $VERSION
      'PREREQ_PM'		=> {}, # e.g., Module::Name => 1.1
      ($] >= 5.005 ?    ## Add these new keywords supported since 5.005
        (ABSTRACT_FROM => 'Mytest.pm', # retrieve abstract from module
         AUTHOR     => 'A. U. Thor <a.u.thor@a.galaxy.far.far.away>') : ()),
      'LIBS'		=> [''], # e.g., '-lm'
      'DEFINE'		=> '', # e.g., '-DHAVE_SOMETHING'
  	# Insert -I. if you add *.h files later:
      'INC'		=> '', # e.g., '-I/usr/include/other'
  	# Un-comment this if you add C files to link with later:
      # 'OBJECT'		=> '$(O_FILES)', # link all the C files too
  );
  ...end of perl_xs/Mytest/Makefile.PL
  

• Then one compiles the module via

   set path = (/var/local/couch/bin $path)
   perl Makefile.PM
   make
  

• and calls it via something like:

  contents of perl_xs/Mytest/test.pl...
  #! /var/local/couch/bin/perl 
  
  # add blib/* directories to include path @INC
  # this is so you won't have to "make install" 
  # to test the library.
  use ExtUtils::testlib; 
  
  BEGIN { print "1..9\n"; } 
  
  use Mytest; 
  Mytest::hello(); 
  print Mytest::is_even(0) == 1 ? "ok 2" : "not ok 2", "\n"; 
  print Mytest::is_even(1) == 0 ? "ok 3" : "not ok 3", "\n"; 
  print Mytest::is_even(2) == 1 ? "ok 4" : "not ok 4", "\n"; 
  $i = -1.5; &Mytest::round($i); print $i == -2.0 ? "ok 5" : "not ok 5", "\n";
  $i = -1.1; &Mytest::round($i); print $i == -1.0 ? "ok 6" : "not ok 6", "\n";
  $i =  0.0; &Mytest::round($i); print $i ==  0.0 ? "ok 7" : "not ok 7", "\n";
  $i =  0.5; &Mytest::round($i); print $i ==  1.0 ? "ok 8" : "not ok 8", "\n";
  $i =  1.2; &Mytest::round($i); print $i ==  1.0 ? "ok 9" : "not ok 9", "\n";
  
  
  ...end of perl_xs/Mytest/test.pl
  

• everything else is a matter of configuring the contents of these files correctly.
  • edit Mytest.xs to construct XSUB's.
  • edit Makefile.PL to specify how to compile your C program.
  • edit Mytest.pm to add Perl or specify how to load your C program.

What XSUB really does:

• The XSUB

  contents of perl_xs/hello.xs...
  void
  hello()
     INPUT: 
     CODE:
         printf("ok 1\n");
  ...end of perl_xs/hello.xs
  

• is compiled into the C code:

  contents of perl_xs/hello.c...
  #line 17 "Mytest.c"
  XS(XS_Mytest_hello); /* prototype to pass -Wmissing-prototypes */
  XS(XS_Mytest_hello)
  {
      dXSARGS;
      if (items != 0)
  	Perl_croak(aTHX_ "Usage: Mytest::hello()");
      {
         printf("ok 1\n");
      }
      XSRETURN_EMPTY;
  }
  ...end of perl_xs/hello.c
  

• which, after preprocessing, is

  contents of perl_xs/hello.i...
  void  XS_Mytest_hello (  CV* cv) ;  
  void  XS_Mytest_hello (  CV* cv) 
  {
      register SV **sp = PL_stack_sp ; 
      register SV **mark = PL_stack_base + (*PL_markstack_ptr--)  ;
      I32 ax = mark  - PL_stack_base + 1 ; 
      I32 items = sp  - mark   ;
      if (items != 0)
  	Perl_croak(  "Usage: Mytest::hello()");
      {
         PerlIO_stdoutf( "ok 1\n"  ) ;
      }
      (void)({
         (void)({ PL_stack_sp = PL_stack_base + ax + (( 0 ) - 1);	return;	}); 
      });
  }
  ...end of perl_xs/hello.i
  

• As a more complex example,

  contents of perl_xs/round.xs...
  void
  round(arg)
      INPUT: 
  	double arg
      CODE: 
  	if (arg>0.0) { 
              arg=floor(arg+0.5); 
  	} else if (arg<0.0) { 
  	    arg=ceil(arg-0.5); 
          } else { 
  	    arg=0.0; 
          }
      OUTPUT: 
          arg
  ...end of perl_xs/round.xs
  

• becomes the C code:

  contents of perl_xs/round.c...
  XS(XS_Mytest_round); /* prototype to pass -Wmissing-prototypes */
  XS(XS_Mytest_round)
  {
      dXSARGS;
      if (items != 1)
  	Perl_croak(aTHX_ "Usage: Mytest::round(arg)");
      {
  	double	arg = (double)SvNV(ST(0));
  	if (arg>0.0) { 
              arg=floor(arg+0.5); 
  	} else if (arg<0.0) { 
  	    arg=ceil(arg-0.5); 
          } else { 
  	    arg=0.0; 
          } 
  	sv_setnv(ST(0), (double)arg);
  	SvSETMAGIC(ST(0));
      }
      XSRETURN_EMPTY;
  }
  ...end of perl_xs/round.c
  

• which, after preprocessing, becomes

  contents of perl_xs/round.i...
  void  XS_Mytest_round (  CV* cv) ;  
  void  XS_Mytest_round (  CV* cv) 
  {
      register SV **sp = PL_stack_sp ; 
      register SV **mark = PL_stack_base + (*PL_markstack_ptr--)  ;        
      I32 ax = mark  - PL_stack_base + 1 ; 
      I32 items = sp  - mark   ;
      if (items != 1)
          Perl_croak(  "Usage: Mytest::round(arg)");
      {
          doublearg = (double)(
              (( PL_stack_base[ax + ( 0 )] )->sv_flags & 0x00020000 ) 
            ? ((XPVNV*)( PL_stack_base[ax + ( 0 )] )->sv_any )->xnv_nv 
            : Perl_sv_2nv ( PL_stack_base[ax + ( 0 )] )) ;
          if (arg>0.0) { 
              arg=floor(arg+0.5); 
          } else if (arg<0.0) { 
              arg=ceil(arg-0.5); 
          } else { 
              arg=0.0; 
          } 
          Perl_sv_setnv (PL_stack_base[ax + ( 0 )] , (double)arg);
          (void)({ 
              if ((( PL_stack_base[ax + ( 0 )] )->sv_flags & 0x00004000 )) 
                  Perl_mg_set ( PL_stack_base[ax + ( 0 )] ); 
          });
      }
      (void)({                
          (void)({        
              PL_stack_sp = PL_stack_base + ax + (( 0 ) - 1);
              return;        
          }); 
      });
  }
  ...end of perl_xs/round.i
  

• In short, the extremely complex process of translating to and from Perl datatypes is hidden from you and made transparent.

XS Syntax

• like Perl, anything not stated is defaulted.
• purpose of XSUB: wrap existing C function calls.
• Minimum code is required for the basic purpose.
• Simplest XSUB

   int blah(int i) { return i*2; } 
   MODULE Foo
   int
   blah(i)
          int i
  

  • type and name must be on different lines.
  • must use old (non-ANSI) variable declarations.
  • everything else is implied.
• CODE block defaults to:

   CODE: 
      RETVAL = blah(i)
  

• OUTPUT block defaults to:

   OUTPUT: 
      RETVAL
  

XSUB Basics

• Every XSUB is called with an argument stack consisting of all arguments passed from Perl to the subroutine.
• These are accessible as ST(0) to ST(n), and are of type SV* (pointer to scalar value).
• The stack base is sp (stack pointer).

XSUB Structure

• Every XSUB has three phases:
• Input type mapping: convert perl arguments to C types.
• Computation: doing something to create outputs from inputs.
• Output type mapping: convert C outputs to Perl types.

Typemaps

• Convert Perl to C types before computation.
• Convert C types back to Perl after computation.
• If C type is SV*, no conversion (scalar input).
• Otherwise, handle conversions to string, int, double, etc.
• Can override this conversion if desired.

XSUB Structure

• Each XSUB consists of blocks starting with a keyword and containing content.
• XSUB blocks specify parts of the XSUB to be inserted.
• PREINIT: variable declarations that should occur first in the subroutine, before type mapping code.

   PREINIT: 
      char *host = "localhost"; 
  

  would create the C variable host.
• INIT: code to be inserted after type mapping and before calling the C function (or CODE, or PPCODE).

   INIT: 
      printf("host is %s\n", host); 
  

  would print the content of the host variable before the CODE segment starts.
• PROTOTYPE: prototype of exposed Perl function arguments (e.g., $$$)
• INPUT: types of input parameters (tag optional).
• CODE: what to do to compute results. Default is to call the C function with the same name as the XSUB.
• OUTPUT: a list of arguments to output (update); may also specify how to output values. Default is RETVAL For example, we could write:

   void stufftime(int *p) { *p=time(0); }
   MODULE Foo
   void
   stufftime(timep)
           time_t &timep
       OUTPUT:
           timep
  

  or take control of output typemapping ourselves:

   void stufftime(int *p) { *p=time(0); }
   MODULE Foo
   void
   stufftime(timep)
           time_t &timep
       OUTPUT:
           timep sv_setnv(ST(0), (double)timep);
  

• PPCODE: how to return special results such as an array or undefined value (incompatible with CODE and OUTPUT).
  • To return an array of values:

     void
     rpcb_gettime(host)
             char *host
         PREINIT:
             time_t  timep;
             bool_t  status;
         PPCODE:
             /* call the rpc time function 
             status = rpcb_gettime( host, &timep );
             EXTEND(sp, 2); /* make room for array */ 
             /* put two scalars into it */ 
             PUSHs(sv_2mortal(newSViv(status))); 
             PUSHs(sv_2mortal(newSViv(timep)));
    

  • To return an undefined value if the system call fails:

     SV *
     rpcb_gettime(host)
           char *  host
         PREINIT:
           time_t  timep;
           bool_t x;
         CODE:
           ST(0) = sv_newmortal();
           if( rpcb_gettime( host, &timep ) )
               sv_setnv( ST(0), (double)timep);
    

    • ST(0): return value (as well as first parameter).
    • Must return a native scalar value (SV *).
    • sv_newmortal(): a pointer to an undef scalar value
    • To return an empty array, use PPCODE, don't EXTEND.

XSUB strangenesses

• XSUB is not C!
• One particularly strange convention: &.
• The argument declaration

   int &k
  

  means that in the context of the function being wrapped, k is a pointer, but in the XSUB context, it's a value. For example:

   void stufftime(int *p) { *p=time(0); }
   MODULE Foo
   void
   stufftime(timep)
           time_t &timep
       OUTPUT:
           timep
  

  • In the context of the C function stufftime, timep is a pointer.
  • In the context of the XSUB, it's a value.

A realistic XS module:

• Here's the Random.xs from Math::Random

  contents of perl_xs/Random.xs...
  #ifdef __cplusplus
  extern "C" {
  #endif
  #include "EXTERN.h"
  #include "perl.h"
  #include "XSUB.h"
  #ifdef __cplusplus
  }
  #endif
  
  #include "randlib.h"
  #include "helper.h"
  
  static int
  not_here(s)
  char *s;
  {
      croak("%s not implemented on this architecture", s);
      return -1;
  }
  
  static double
  constant(name, arg)
  char *name;
  int arg;
  {
      errno = 0;
      switch (*name) {
      }
      errno = EINVAL;
      return 0;
  
  not_there:
      errno = ENOENT;
      return 0;
  }
  
  
  MODULE = Math::Random		PACKAGE = Math::Random		
  
  
  double
  genbet (aa,bb)
  	INPUT:
  	double  aa
  	double  bb
  
  double
  genchi (df)
  	INPUT:
  	double  df
  
  double
  genexp (av)
  	INPUT:
  	double  av
  
  double
  genf (dfn,dfd)
  	INPUT:
  	double  dfn
  	double  dfd
  
  double
  gengam (a,r)
  	INPUT:
  	double  a
  	double  r
  
  int
  psetmn (p)
  	INPUT:
  	long  p
  
  int
  pgenmn ()
  	PROTOTYPE:
  	INPUT:
  	CODE:
  	RETVAL = pgenmn();
  	OUTPUT:
  	RETVAL
  
  int
  rspriw (size)
  	INPUT:
  	long  size
  
  int
  rsprfw (size)
  	INPUT:
  	long  size
  
  void
  svprfw (index,value)
  	INPUT:
  	long  index
  	double  value
  
  void
  pgnmul (n,ncat)
  	INPUT:
  	long  n
  	long  ncat
  
  long
  gvpriw (index)
  	INPUT:
  	long  index
  
  double
  gennch (df,xnonc)
  	INPUT:
  	double  df
  	double  xnonc
  
  double
  gennf (dfn,dfd,xnonc)
  	INPUT:
  	double  dfn
  	double  dfd
  	double  xnonc
  
  double
  gennor (av,sd)
  	INPUT:
  	double  av
  	double  sd
  
  void
  pgnprm (n)
  	PROTOTYPE: $
  	INPUT:
  	long  n
  	CODE:
  	pgnprm(n);
  	OUTPUT:
  
  double
  genunf (low,high)
  	INPUT:
  	double  low
  	double  high
  
  long
  ignpoi (mu)
  	INPUT:
  	double  mu
  
  long
  ignuin (low,high)
  	INPUT:
  	long  low
  	long  high
  
  long
  ignnbn (n,p)
  	INPUT:
  	long  n
  	double  p
  
  long
  ignbin (n,pp)
  	INPUT:
  	long  n
  	double  pp
  
  void
  phrtsd (phrase,seed1,seed2)
  	PROTOTYPE: $$$
  	INPUT:
  	char *  phrase
  	void *  seed1
  	void *  seed2
  	PREINIT:
  	long  newseed1;
  	long  newseed2;
  	PPCODE:
  	phrtsd(phrase,&newseed1,&newseed2);
  	EXTEND(sp, 2);
  	PUSHs(sv_2mortal(newSViv(newseed1)));
  	PUSHs(sv_2mortal(newSViv(newseed2)));
  
  void
  getsd (iseed1,iseed2)
  	PROTOTYPE: $$
  	INPUT:
  	void *  iseed1
  	void *  iseed2
  	PREINIT:
  	long  newseed1;
  	long  newseed2;
  	PPCODE:
  	getsd(&newseed1,&newseed2);
  	EXTEND(sp, 2);
  	PUSHs(sv_2mortal(newSViv(newseed1)));
  	PUSHs(sv_2mortal(newSViv(newseed2)));
  
  void
  salfph (phrase)
  	PROTOTYPE: $
  	INPUT:
  	char *  phrase
  	CODE:
  	salfph(phrase);
  	OUTPUT:
  
  void
  setall (iseed1,iseed2)
  	PROTOTYPE: $$
  	INPUT:
  	long  iseed1
  	long  iseed2
  	CODE:
  	setall(iseed1,iseed2);
  	OUTPUT:
  
  double
  gvprfw (index)
  	INPUT:
  	long  index
  
  ...end of perl_xs/Random.xs
  

Calling Perl from C

• The other way around: calling Perl from C

  contents of perl_xs/miniperl.c...
  #include <EXTERN.h>               /* from the Perl distribution     */          #include <perl.h>                 /* from the Perl distribution     *
  static PerlInterpreter *my_perl;  /***    The Perl interpreter    ***/
  
  int main(int argc, char **argv, char **env)
  {
      my_perl = perl_alloc();
      perl_construct(my_perl);
      perl_parse(my_perl, NULL, argc, argv, (char **)NULL);
      perl_run(my_perl);
      perl_destruct(my_perl);
      perl_free(my_perl);
  }
  
  ...end of perl_xs/miniperl.c
  

• Compile this with

   set path = (/var/local/couch/bin $path) 
   gcc -o interp miniperlmain.c `perl -MExtUtils::Embed -e ccopts -e ldopts`
  

• Perl statement dumps the compile line options used to originally compile the interpreter.

Calling a perl subroutine from C:

• Create interpreter
• Skip running it.
• Invoke the subroutine instead.
• Convert values appropriately.
• Consider

  contents of perl_xs/showtime.c...
  #include <EXTERN.h>
  #include <perl.h>
  
  static PerlInterpreter *my_perl;
  
  int main(int argc, char **argv, char **env)
  {
      char *args[] = { NULL };
      my_perl = perl_alloc();
      perl_construct(my_perl);
  
      perl_parse(my_perl, NULL, argc, argv, NULL);
  
      /*** skipping perl_run() ***/
  
      call_argv("showtime", G_DISCARD | G_NOARGS, args);
   
      perl_destruct(my_perl);
      perl_free(my_perl);
  }
  ...end of perl_xs/showtime.c
  

  (source: man perlembed)

Evaluating a random Perl statement from C

• Create interpreter
• Skip running it.
• use builtins eval_sv and eval_pv
• Consider

  contents of perl_xs/eval.c...
  #include <EXTERN.h>
  #include <perl.h>
  
  static PerlInterpreter *my_perl;
  
  main (int argc, char **argv, char **env)
  {
      STRLEN n_a;
      char *embedding[] = { "", "-e", "0" };
  
      my_perl = perl_alloc();
      perl_construct( my_perl );
  
      perl_parse(my_perl, NULL, 3, embedding, NULL);
      perl_run(my_perl);
  
      /** Treat $a as an integer **/
      eval_pv("$a = 3; $a **= 2", TRUE);
      printf("a = %d\n", SvIV(get_sv("a", FALSE)));
  
      /** Treat $a as a float **/
      eval_pv("$a = 3.14; $a **= 2", TRUE);
      printf("a = %f\n", SvNV(get_sv("a", FALSE)));
  
     /** Treat $a as a string **/
      eval_pv("$a = 'rekcaH lreP rehtonA tsuJ'; $a = reverse($a);", TRUE);
      printf("a = %s\n", SvPV(get_sv("a", FALSE), n_a));
  
      perl_destruct(my_perl);
      perl_free(my_perl);
  }
  ...end of perl_xs/eval.c
  

  (source: man perlembed)