Algorithm-LBFGS

 view release on metacpan or  search on metacpan

Algorithm-LBFGS.xs  view on Meta::CPAN

    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 */

Algorithm-LBFGS.xs  view on Meta::CPAN

    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

Algorithm-LBFGS.xs  view on Meta::CPAN

        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)

Algorithm-LBFGS.xs  view on Meta::CPAN

	}
	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;

Algorithm-LBFGS.xs  view on Meta::CPAN

	/* 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:

Algorithm-LBFGS.xs  view on Meta::CPAN

	    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

ppport.h  view on Meta::CPAN

PTR2UV|5.006000||p
PTR2ul|5.007001||p
PTRV|5.006000||p
PUSHMARK|||
PUSHi|||
PUSHmortal|5.009002||p
PUSHn|||
PUSHp|||
PUSHs|||
PUSHu|5.004000||p
PUTBACK|||
PerlIO_clearerr||5.007003|
PerlIO_close||5.007003|
PerlIO_eof||5.007003|
PerlIO_error||5.007003|
PerlIO_fileno||5.007003|
PerlIO_fill||5.007003|
PerlIO_flush||5.007003|
PerlIO_get_base||5.007003|
PerlIO_get_bufsiz||5.007003|
PerlIO_get_cnt||5.007003|

ppport.h  view on Meta::CPAN

{
    dSP;
    SV* sv = newSVpv(p, 0);

    PUSHMARK(sp);
    eval_sv(sv, G_SCALAR);
    SvREFCNT_dec(sv);

    SPAGAIN;
    sv = POPs;
    PUTBACK;

    if (croak_on_error && SvTRUE(GvSV(errgv)))
	croak(SvPVx(GvSV(errgv), na));

    return sv;
}

#endif
#endif
#ifndef newRV_inc