Skip to content

Commit

Permalink
reworking some of the ugly bits
Browse files Browse the repository at this point in the history 
 * use ExtUtils::Embed to generate xs_init()
 * simplify context switch between Go and Perl
 * fix uninitialized memory in return value list to Go from Perl
 * unwrap Go funcs when they return to Go from Perl
 * unwrap Go structs when they return to Go from Perl
 * cgo compile flags from perl in path rather than /usr/bin/perl
 * `go fmt`
  • Loading branch information
@tlby
tlby committed Jun 10, 2020
1 parent 4b4881b commit 2397c53
Show file tree
Hide file tree
Showing 6 changed files with 208 additions and 121 deletions.
5 changes: 3 additions & 2 deletions gen.pl
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
#!/usr/bin/perl
#!/usr/bin/env perl
use strict;
use warnings;
use ExtUtils::Embed ();
Expand All @@ -11,8 +11,9 @@ sub trim {

my($fn) = @ARGV;

ExtUtils::Embed::xsinit(undef, undef, []);
# CVE-2018-6574: cgo no longer allows some linker flags
my $ccopts = trim(ExtUtils::Embed::ccopts());
my $ccopts = trim(ExtUtils::Embed::ccopts()) =~ s/-fwrapv\s*//sgr;
my $ldopts = trim(ExtUtils::Embed::ldopts()) =~ s/-[Wf]\S*\s*//sgr;

my $hdr = qq{/*
Expand Down
74 changes: 37 additions & 37 deletions glue.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,11 +7,7 @@
* allocated and caller freed so that the go side isn't peppered with
* tons of defer calls */

extern void boot_DynaLoader (pTHX_ CV *cv);

static void xs_init(pTHX) {
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__);
}
void xs_init (pTHX); /* provided by perlxsi.c */

/* A little macro nuttiness to get Perl errors report the correct file
* and line. */
Expand Down Expand Up @@ -44,7 +40,6 @@ typedef struct {
} glue_st_t;

static int vtbl_st_sv_free(pTHX_ SV *sv, MAGIC *mg) {
PERL_SET_CONTEXT(my_perl);
glue_st_t *st = (glue_st_t *)mg->mg_ptr;
goReleaseST(st->st_id);
if(st->st_fname)
Expand Down Expand Up @@ -128,13 +123,11 @@ tTHX glue_init() {
}

void glue_fini(pTHX) {
PERL_SET_CONTEXT(my_perl);
perl_destruct(my_perl);
perl_free(my_perl);
}

SV *glue_eval(pTHX_ char *text, SV **errp) {
PERL_SET_CONTEXT(my_perl);
SV *rv;
ENTER;
SAVETMPS;
Expand All @@ -151,14 +144,14 @@ SV *glue_eval(pTHX_ char *text, SV **errp) {
return rv;
}

SV *glue_call_sv(pTHX_ SV *sv, SV **arg, SV **ret, IV n) {
SV *glue_call_sv(pTHX_ SV *sv, SV **arg, SV **ret, UV n) {
I32 ax;
I32 count;
dSP;
int flags;
SV *err;
UV i = 0;

PERL_SET_CONTEXT(my_perl);
switch(n) {
case 0: flags = G_VOID; break;
case 1: flags = G_SCALAR; break;
Expand All @@ -180,34 +173,35 @@ SV *glue_call_sv(pTHX_ SV *sv, SV **arg, SV **ret, IV n) {
if(SvTRUE(ERRSV)) {
err = newSVsv(ERRSV);
} else {
int i;
for(i = 0; i < count && i < n; i++) {
while(i < count && i < n) {
ret[i] = ST(i);
// callee passes mortal rets, caller wants ownership
SvREFCNT_inc(ret[i]);
i++;
}
err = NULL;
}
PUTBACK;
FREETMPS;
LEAVE;
if(i < n)
memset(ret + i, '\0', sizeof(SV *) * (n - i));
return err;
}

void glue_inc(pTHX_ SV *sv) {
PERL_SET_CONTEXT(my_perl);
SvREFCNT_inc(sv);
}

void glue_dec(pTHX_ SV *sv) {
if(sv == NULL)
/* Go might hand us a null ptr because we sometimes return a null in
* place of ERRSV to mean no error occured. */
if(!sv)
return;
PERL_SET_CONTEXT(my_perl);
SvREFCNT_dec(sv);
}

IV glue_count_live(pTHX) {
PERL_SET_CONTEXT(my_perl);
/* Devel::Leak proved to be too expensive to run during scans, so
* this lifts a bit of it's algorithm for something to give us
* simple live variable allocation counts */
Expand All @@ -226,40 +220,33 @@ SV **glue_alloc(IV n) {
}

void glue_dump(pTHX_ SV *sv) {
PERL_SET_CONTEXT(my_perl);
sv_dump(sv);
}

void glue_getBool(pTHX_ bool *dst, SV *sv) {
PERL_SET_CONTEXT(my_perl);
*dst = SvTRUE(sv);
}

void glue_getIV(pTHX_ IV *dst, SV *sv) {
PERL_SET_CONTEXT(my_perl);
*dst = SvIV(sv);
}

void glue_getUV(pTHX_ UV *dst, SV *sv) {
PERL_SET_CONTEXT(my_perl);
*dst = SvUV(sv);
}

void glue_getNV(pTHX_ NV *dst, SV *sv) {
PERL_SET_CONTEXT(my_perl);
*dst = SvNV(sv);
}

void glue_getPV(pTHX_ char **dst, STRLEN *len, SV *sv) {
PERL_SET_CONTEXT(my_perl);
*dst = SvPV(sv, *len);
}

void glue_walkAV(pTHX_ SV *sv, UV data) {
SV **lst = NULL;
I32 len = -1;

PERL_SET_CONTEXT(my_perl);
SAVETMPS;
if(SvROK(sv)) {
AV *av = (AV *)SvRV(sv);
Expand All @@ -276,7 +263,6 @@ void glue_walkHV(pTHX_ SV *sv, UV data) {
IV len = -1;
SV **lst = NULL;

PERL_SET_CONTEXT(my_perl);
SAVETMPS;
if(SvROK(sv)) {
HV *hv = (HV *)SvRV(sv);
Expand All @@ -297,33 +283,26 @@ void glue_walkHV(pTHX_ SV *sv, UV data) {
}

void glue_setBool(pTHX_ SV **ptr, bool v) {
PERL_SET_CONTEXT(my_perl);

if(!*ptr) *ptr = newSV(0);
SvSetSV(*ptr, boolSV(v));
}

void glue_setIV(pTHX_ SV **ptr, IV v) {
PERL_SET_CONTEXT(my_perl);

if(!*ptr) *ptr = newSV(0);
sv_setiv(*ptr, v);
}

void glue_setUV(pTHX_ SV **ptr, UV v) {
PERL_SET_CONTEXT(my_perl);
if(!*ptr) *ptr = newSV(0);
sv_setuv(*ptr, v);
}

void glue_setNV(pTHX_ SV **ptr, NV v) {
PERL_SET_CONTEXT(my_perl);
if(!*ptr) *ptr = newSV(0);
sv_setnv(*ptr, v);
}

void glue_setPV(pTHX_ SV **ptr, char *str, STRLEN len) {
PERL_SET_CONTEXT(my_perl);
if(!*ptr) *ptr = newSV(len);
sv_setpvn(*ptr, str, len);
free(str);
Expand All @@ -336,15 +315,13 @@ static inline void setRV(pTHX_ SV **ptr, SV *elt) {
}

void glue_setAV(pTHX_ SV **ptr, SV **lst) {
PERL_SET_CONTEXT(my_perl);
AV *av = newAV();
while(*lst)
av_push(av, *lst++);
setRV(aTHX_ (SV **)ptr, (SV *)av);
}

void glue_setHV(pTHX_ SV **ptr, SV **lst) {
PERL_SET_CONTEXT(my_perl);
HV *hv = newHV();
while(*lst) {
SV *k = *lst++;
Expand All @@ -358,7 +335,6 @@ void glue_setHV(pTHX_ SV **ptr, SV **lst) {

/* When Perl releases our CV we should notify Go */
static int vtbl_cb_sv_free(pTHX_ SV *sv, MAGIC *mg) {
PERL_SET_CONTEXT(my_perl);
UV id = (UV)mg->mg_ptr;
goReleaseCB(id);
return 0;
Expand Down Expand Up @@ -392,7 +368,6 @@ XS(glue_invoke)

/* Tie a CV to glue_invoke() and stash the Go details */
void glue_setCV(pTHX_ SV **ptr, UV id) {
PERL_SET_CONTEXT(my_perl);
CV *cv = newXS(NULL, glue_invoke, __FILE__);
sv_magicext((SV *)cv, 0, PERL_MAGIC_ext, &vtbl_cb, (char *)id, 0);
setRV(aTHX_ (SV **)ptr, (SV *)cv);
Expand All @@ -404,14 +379,12 @@ void glue_setObj(pTHX_ SV **ptr, UV id, char *gotype, char **attrs) {
HV *hv;
SV *sv;
glue_st_t st;
PERL_SET_CONTEXT(my_perl);

SAVETMPS;
hv = newHV();
setRV(aTHX_ (SV **)ptr, (SV *)hv);
sv = *ptr;


//ENTER;
//PUSHMARK(SP);
//mXPUSHs(newSVpv(gotype, 0));
Expand Down Expand Up @@ -443,3 +416,30 @@ void glue_setObj(pTHX_ SV **ptr, UV id, char *gotype, char **attrs) {
SvREADONLY_on((SV *)hv);
FREETMPS;
}

bool glue_getId(pTHX_ SV *sv, UV *id, const char *kind) {
MAGIC *mg;
if(strcmp(kind, "func") == 0) {
SV *cv = SvRV(sv);
if(!SvMAGICAL(cv))
return FALSE;
if(!(mg = mg_findext(cv, PERL_MAGIC_ext, &vtbl_cb)))
return FALSE;
*id = (UV)mg->mg_ptr;
return TRUE;
}
if(strcmp(kind, "struct") == 0) {
if(!SvMAGICAL(sv))
return FALSE;
if(!(mg = mg_findext(sv, PERL_MAGIC_ext, &vtbl_st)))
return FALSE;
glue_st_t *st = (glue_st_t *)mg->mg_ptr;
*id = st->st_id;
return TRUE;
}
croak("Unsupported kind %s", kind);
}

void glue_setContext(pTHX) {
PERL_SET_CONTEXT(my_perl);
}
4 changes: 3 additions & 1 deletion glue.h
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,7 +8,7 @@ tTHX glue_init();
void glue_fini(pTHX);

SV *glue_eval(pTHX_ char *, SV **);
SV *glue_call_sv(pTHX_ SV *, SV **, SV **, IV);
SV *glue_call_sv(pTHX_ SV *, SV **, SV **, UV);

void glue_inc(pTHX_ SV *);
void glue_dec(pTHX_ SV *);
Expand All @@ -35,3 +35,5 @@ void glue_setAV(pTHX_ SV **, SV **);
void glue_setHV(pTHX_ SV **, SV **);
void glue_setCV(pTHX_ SV **, UV);
void glue_setObj(pTHX_ SV **, UV, char *, char **);
bool glue_getId(pTHX_ SV *, UV *, const char *);
void glue_setContext(pTHX);
Loading

0 comments on commit 2397c53

Please sign in to comment.