Algorithm-LBFGS.xs - metacpan.org

/**************************************************************************
 * XS of Algorithm::LBFGS
 * -> by Laye Suen
 **************************************************************************/

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

#include "ppport.h"

#include "lbfgs.h"

/* Macros for debugging */

/* uncomment the line below to enable tracing and timing */
/* #define __ENABLE_TRACING__ */

#ifdef __ENABLE_TRACING__

#include "time.h"

#define TRACE(msg) \
    printf(msg); \
    printf(": %0.10f s\n", 1.0 * (clock() - _c) / CLOCKS_PER_SEC); \
    fflush(stdout); \
    _c = clock()
#define dTRACE clock_t _c = clock()

#else

#define TRACE(msg)
#define dTRACE

#endif

/* Other macros */

#define newSVpv_(x) newSVpv(x, strlen(x))

/**************************************************************************
 * NON-EXPORTED SUBS
 **************************************************************************/

/* Evaluation callback for L-BFGS */
lbfgsfloatval_t lbfgs_evaluation_cb(
    void*                    instance,
    const lbfgsfloatval_t*   x,
    lbfgsfloatval_t*         g,
    const int                n,
    const lbfgsfloatval_t    step)
{
    int i;
    SV *lbfgs_eval, *user_data, *sv_f;
    AV *av_x, *av_g;
    lbfgsfloatval_t f;
    dSP;
    dTRACE;
    /* fetch refs to user evaluation callback and extra data */
    TRACE("lbfgs_evaluation_cb: enter");
    lbfgs_eval = ((SV**)instance)[0];
    user_data = ((SV**)instance)[2];
    /* create an AV av_x from the C array x */
    av_x = newAV();
    av_extend(av_x, n - 1);
    for (i = 0; i < n; i++) av_store(av_x, i, newSVnv(x[i]));
    /* call the user evaluation callback */
    ENTER;
    SAVETMPS;
    PUSHMARK(SP);
    XPUSHs(sv_2mortal(newRV_noinc((SV*)av_x)));
    XPUSHs(sv_2mortal(newSVnv(step)));
    XPUSHs(user_data);
    PUTBACK;
    TRACE("lbfgs_evaluation_cb: finish arguments preparation");
    call_sv(lbfgs_eval, G_ARRAY);
    TRACE("lbfgs_evaluation_cb: finish calling");
    SPAGAIN;
    av_g = (AV*)SvRV(POPs);
    sv_f = POPs;
    f = SvNV(sv_f);
    for (i = 0; i < n; i++)
        g[i] = SvNV(*av_fetch(av_g, i, 0));
    PUTBACK;
    FREETMPS;
    LEAVE;
    /* clean up (for non-mortal return values) */
    if (SvREFCNT(av_g) > 0) av_undef(av_g);
    if (SvREFCNT(sv_f) > 0) SvREFCNT_dec(sv_f);
    TRACE("lbfgs_evaluation_cb: leave");
    return f;
}

/* Progress callback for L-BFGS */
int lbfgs_progress_cb(
    void*                    instance,
    const lbfgsfloatval_t*   x,
    const lbfgsfloatval_t*   g,
    const lbfgsfloatval_t    fx,
    const lbfgsfloatval_t    xnorm,
    const lbfgsfloatval_t    gnorm,
    const lbfgsfloatval_t    step,
    int                      n,
    int                      k,
    int                      ls)
{
    int i, r;
    SV *lbfgs_prgr, *user_data, *sv_r;
    AV *av_x, *av_g;
    dSP;
    dTRACE;
    /* fetch refs to the user progress callback and extra data */
    TRACE("lbfgs_progress_cb: enter");
    lbfgs_prgr = ((SV**)instance)[1];
    user_data = ((SV**)instance)[2];
    /* create AVs for C array x and g */
    av_x = newAV();
    for (i = 0; i < n; i++) av_store(av_x, i, newSVnv(x[i]));
    av_g = newAV();
    for (i = 0; i < n; i++) av_store(av_g, i, newSVnv(g[i]));
    /* call the user progress callback */
    ENTER;
    SAVETMPS;
    PUSHMARK(SP);
    XPUSHs(sv_2mortal(newRV_noinc((SV*)av_x)));
    XPUSHs(sv_2mortal(newRV_noinc((SV*)av_g)));
    XPUSHs(sv_2mortal(newSVnv(fx)));
    XPUSHs(sv_2mortal(newSVnv(xnorm)));
    XPUSHs(sv_2mortal(newSVnv(gnorm)));
    XPUSHs(sv_2mortal(newSVnv(step)));
    XPUSHs(sv_2mortal(newSViv(k)));
    XPUSHs(sv_2mortal(newSViv(ls)));
    XPUSHs(user_data);
    PUTBACK;
    TRACE("lbfgs_progress_cb: finish arguments preparation");
    call_sv(lbfgs_prgr, G_ARRAY);
    TRACE("lbfgs_progress_cb: finish calling");
    SPAGAIN;
    sv_r = POPs;
    r = SvIV(sv_r);
    PUTBACK;
    FREETMPS;
    LEAVE;
    /* clean up (for non-mortal return values) */
    if (SvREFCNT(sv_r) > 0) SvREFCNT_dec(sv_r);
    TRACE("lbfgs_progress_cb: leave");
    return r;
}

/**************************************************************************
 * EXPORTED XSUBS
 **************************************************************************/
MODULE = Algorithm::LBFGS		PACKAGE = Algorithm::LBFGS

void*
create_lbfgs_instance(lbfgs_eval, lbfgs_prgr, user_data)
        SV*     lbfgs_eval
	SV*     lbfgs_prgr
	SV*	user_data
    PREINIT:
        void* instance = malloc(3 * sizeof(SV*));
    CODE:
        ((SV**)instance)[0] = lbfgs_eval; /* ref to Perl eval callback */
	((SV**)instance)[1] = lbfgs_prgr; /* ref to Perl monitor callback */
	((SV**)instance)[2] = user_data;  /* ref to Perl user data */
	RETVAL = instance;
    OUTPUT:
        RETVAL

void
destroy_lbfgs_instance(li)
        void*   li
    CODE:
        free(li);


void*
create_lbfgs_param()
    PREINIT:
        void* lp = malloc(sizeof(lbfgs_parameter_t));
    CODE:
        lbfgs_parameter_init((lbfgs_parameter_t*)lp);
	RETVAL = lp;
    OUTPUT:
        RETVAL

void
destroy_lbfgs_param(lp)
        void*   lp
    CODE:
        free(lp);

SV*
set_lbfgs_param(lp, name, val)
        void*   lp
	char*   name
	SV*     val
    PREINIT:
        lbfgs_parameter_t* p = (lbfgs_parameter_t*)lp;
	SV* r = &PL_sv_undef;
    CODE:
        if (strcmp(name, "m") == 0) {
	    if (SvIOK(val)) p->m = SvIV(val);
	    r = newSViv(p->m);
	}
	else if (strcmp(name, "epsilon") == 0) {
	    if (SvNOK(val)) p->epsilon = SvNV(val);
	    r = newSVnv(p->epsilon);
	}
	else if (strcmp(name, "max_iterations") == 0) {
	    if (SvIOK(val)) p->max_iterations = SvIV(val);
	    r = newSViv(p->max_iterations);
	}
	else if (strcmp(name, "max_linesearch") == 0) {
	    if (SvIOK(val)) p->max_linesearch = SvIV(val);
	    r = newSViv(p->max_linesearch);
	}
	else if (strcmp(name, "min_step") == 0) {
	    if (SvNOK(val)) p->min_step = SvNV(val);
	    r = newSVnv(p->min_step);
	}
	else if (strcmp(name, "max_step") == 0) {
	    if (SvNOK(val)) p->max_step = SvNV(val);
	    r = newSVnv(p->max_step);
	}
	else if (strcmp(name, "ftol") == 0) {
	    if (SvNOK(val)) p->ftol = SvNV(val);
	    r = newSVnv(p->ftol);
	}
	else if (strcmp(name, "gtol") == 0) {
	    if (SvNOK(val)) p->gtol = SvNV(val);
	    r = newSVnv(p->gtol);
	}
	else if (strcmp(name, "xtol") == 0) {
	    if (SvNOK(val)) p->xtol = SvNV(val);
	    r = newSVnv(p->xtol);
	}
	else if (strcmp(name, "orthantwise_c") == 0) {
	    if (SvNOK(val)) p->orthantwise_c = SvNV(val);
	    r = newSVnv(p->orthantwise_c);
	}
	RETVAL = r;
    OUTPUT:
        RETVAL

SV*
do_lbfgs(param, instance, x0)
        void*   param
	void*   instance
	SV*     x0
    PREINIT:
        AV* av_x0 = (AV*)SvRV(x0);
	int n = av_len(av_x0) + 1;
	int i, s;
    CODE:
	/* build C array carr_x0 from Perl array ref x0 */
	lbfgsfloatval_t* carr_x0 = (lbfgsfloatval_t*)
	    malloc(n * sizeof(lbfgsfloatval_t));
	for (i = 0; i < n; i++) carr_x0[i] = SvNV(*av_fetch(av_x0, i, 0));
	/* call L-BFGS */
	s = lbfgs(n, carr_x0, NULL, 
                  SvOK(((SV**)instance)[0]) ? &lbfgs_evaluation_cb : NULL,
                  SvOK(((SV**)instance)[1]) ? &lbfgs_progress_cb : NULL,
                  instance, (lbfgs_parameter_t*)param);
        /* store the result back to the Perl array ref x0 */
	for (i = 0; i < n; i++) av_store(av_x0, i, newSVnv(carr_x0[i]));
	/* release the C array */
	free(carr_x0);
	RETVAL = newSViv(s);
    OUTPUT:
        RETVAL

SV*
status_2pv(status)
        int     status
    CODE:
        switch (status) {
	case 0:
	    RETVAL = newSVpv_("LBFGS_OK"); break;
	case LBFGSERR_UNKNOWNERROR:
	    RETVAL = newSVpv_("LBFGSERR_UNKNOWNERROR"); break;
	case LBFGSERR_LOGICERROR:
	    RETVAL = newSVpv_("LBFGSERR_LOGICERROR"); break;
	case LBFGSERR_OUTOFMEMORY:
	    RETVAL = newSVpv_("LBFGSERR_OUTOFMEMORY"); break;
	case LBFGSERR_CANCELED:
	    RETVAL = newSVpv_("LBFGSERR_CANCELED"); break;
	case LBFGSERR_INVALID_N:
	    RETVAL = newSVpv_("LBFGSERR_INVALID_N"); break;
	case LBFGSERR_INVALID_N_SSE:
	    RETVAL = newSVpv_("LBFGSERR_INVALID_N_SSE"); break;
	case LBFGSERR_INVALID_MINSTEP:
	    RETVAL = newSVpv_("LBFGSERR_INVALID_MINSTEP"); break;
	case LBFGSERR_INVALID_MAXSTEP:
	    RETVAL = newSVpv_("LBFGSERR_INVALID_MAXSTEP"); break;
	case LBFGSERR_INVALID_FTOL:
	    RETVAL = newSVpv_("LBFGSERR_INVALID_FTOL"); break;
	case LBFGSERR_INVALID_GTOL:
	    RETVAL = newSVpv_("LBFGSERR_INVALID_GTOL"); break;
	case LBFGSERR_INVALID_XTOL:
	    RETVAL = newSVpv_("LBFGSERR_INVALID_XTOL"); break;
	case LBFGSERR_INVALID_MAXLINESEARCH:
	    RETVAL = newSVpv_("LBFGSERR_INVALID_MAXLINESEARCH"); break;
	case LBFGSERR_INVALID_ORTHANTWISE:
	    RETVAL = newSVpv_("LBFGSERR_INVALID_ORTHANTWISE"); break;
	case LBFGSERR_OUTOFINTERVAL:
	    RETVAL = newSVpv_("LBFGSERR_OUTOFINTERVAL"); break;
	case LBFGSERR_INCORRECT_TMINMAX:
	    RETVAL = newSVpv_("LBFGSERR_INCORRECT_TMINMAX"); break;
	case LBFGSERR_ROUNDING_ERROR:
	    RETVAL = newSVpv_("LBFGSERR_ROUNDING_ERROR"); break;
	case LBFGSERR_MINIMUMSTEP:
	    RETVAL = newSVpv_("LBFGSERR_MINIMUMSTEP"); break;
	case LBFGSERR_MAXIMUMSTEP:
	    RETVAL = newSVpv_("LBFGSERR_MAXIMUMSTEP"); break;
	case LBFGSERR_MAXIMUMLINESEARCH:
	    RETVAL = newSVpv_("LBFGSERR_MAXIMUMLINESEARCH"); break;
	case LBFGSERR_MAXIMUMITERATION:
	    RETVAL = newSVpv_("LBFGSERR_MAXIMUMITERATION"); break;
	case LBFGSERR_WIDTHTOOSMALL:
	    RETVAL = newSVpv_("LBFGSERR_WIDTHTOOSMALL"); break;
	case LBFGSERR_INVALIDPARAMETERS:
	    RETVAL = newSVpv_("LBFGSERR_INVALIDPARAMETERS"); break;
	case LBFGSERR_INCREASEGRADIENT:
	    RETVAL = newSVpv_("LBFGSERR_INCREASEGRADIENT"); break;
	default:
	    RETVAL = newSVpv_(""); break;
	}
    OUTPUT:
        RETVAL
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)