From: Adrian M. Enache <enache@rdslink.ro>
Date: Tue, 2 Sep 2003 03:45:11 +0000 (+0300)
Subject: Re: ByteLoader and MSWin32
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c7e45529067e5669196da1c88cb491070e8fe1ea;p=p5sagit%2Fp5-mst-13.2.git

Re: ByteLoader and MSWin32
Message-ID: <20030902004511.GA1442@ratsnest.hole>

p4raw-id: //depot/perl@20993
---

diff --git a/embed.fnc b/embed.fnc
index 04b134f..26d3bd5 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1025,10 +1025,10 @@ s	|OP *	|my_kid		|OP *o|OP *attrs|OP **imopsp
 s	|OP *	|dup_attrlist	|OP *o
 s	|void	|apply_attrs	|HV *stash|SV *target|OP *attrs|bool for_my
 s	|void	|apply_attrs_my	|HV *stash|OP *target|OP *attrs|OP **imopsp
-#  if defined(PL_OP_SLAB_ALLOC)
-s	|void*	|Slab_Alloc	|int m|size_t sz
-s	|void	|Slab_Free	|void *op
-#  endif
+#endif
+#if defined(PL_OP_SLAB_ALLOC)
+Ap	|void*	|Slab_Alloc	|int m|size_t sz
+Ap	|void	|Slab_Free	|void *op
 #endif
 
 #if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT)
diff --git a/embed.h b/embed.h
index 18b117a..873cb04 100644
--- a/embed.h
+++ b/embed.h
@@ -1387,14 +1387,10 @@
 #ifdef PERL_CORE
 #define apply_attrs_my		S_apply_attrs_my
 #endif
-#  if defined(PL_OP_SLAB_ALLOC)
-#ifdef PERL_CORE
-#define Slab_Alloc		S_Slab_Alloc
-#endif
-#ifdef PERL_CORE
-#define Slab_Free		S_Slab_Free
 #endif
-#  endif
+#if defined(PL_OP_SLAB_ALLOC)
+#define Slab_Alloc		Perl_Slab_Alloc
+#define Slab_Free		Perl_Slab_Free
 #endif
 #if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT)
 #ifdef PERL_CORE
@@ -3873,14 +3869,10 @@
 #ifdef PERL_CORE
 #define apply_attrs_my(a,b,c,d)	S_apply_attrs_my(aTHX_ a,b,c,d)
 #endif
-#  if defined(PL_OP_SLAB_ALLOC)
-#ifdef PERL_CORE
-#define Slab_Alloc(a,b)		S_Slab_Alloc(aTHX_ a,b)
-#endif
-#ifdef PERL_CORE
-#define Slab_Free(a)		S_Slab_Free(aTHX_ a)
 #endif
-#  endif
+#if defined(PL_OP_SLAB_ALLOC)
+#define Slab_Alloc(a,b)		Perl_Slab_Alloc(aTHX_ a,b)
+#define Slab_Free(a)		Perl_Slab_Free(aTHX_ a)
 #endif
 #if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT)
 #ifdef PERL_CORE
diff --git a/ext/ByteLoader/bytecode.h b/ext/ByteLoader/bytecode.h
index 7fb91da..d264482 100644
--- a/ext/ByteLoader/bytecode.h
+++ b/ext/ByteLoader/bytecode.h
@@ -191,14 +191,14 @@ typedef char *pvindex;
 	    SvFLAGS(sv) = arg;				\
 	    BSET_OBJ_STOREX(sv);			\
 	} STMT_END
-#define BSET_newop(o, arg)				\
-	((o = (OP*)safemalloc(arg)), memzero((char*)o,arg))
+
+#define BSET_newop(o, arg)	NewOpSz(666, o, arg)
 #define BSET_newopx(o, arg) STMT_START {	\
 	register int sz = arg & 0x7f;		\
-	register OP* new = (OP*) safemalloc(sz);\
-	memzero(new, sz);			\
-	/* new->op_next = o; XXX */		\
-	o = new;				\
+	register OP* newop;			\
+	BSET_newop(newop, sz);			\
+	/* newop->op_next = o; XXX */		\
+	o = newop;				\
 	arg >>=7;				\
 	BSET_op_type(o, arg);			\
 	BSET_OBJ_STOREX(o);			\
diff --git a/global.sym b/global.sym
index 8d0e0da..3496198 100644
--- a/global.sym
+++ b/global.sym
@@ -628,6 +628,8 @@ Perl_sv_nosharing
 Perl_sv_nolocking
 Perl_sv_nounlocking
 Perl_nothreadhook
+Perl_Slab_Alloc
+Perl_Slab_Free
 Perl_sv_setsv_flags
 Perl_sv_catpvn_flags
 Perl_sv_catsv_flags
diff --git a/op.c b/op.c
index d859e2a..991a426 100644
--- a/op.c
+++ b/op.c
@@ -30,13 +30,8 @@
 #define PERL_SLAB_SIZE 2048
 #endif
 
-#define NewOp(m,var,c,type) \
-	STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
-
-#define FreeOp(p) Slab_Free(p)
-
-STATIC void *
-S_Slab_Alloc(pTHX_ int m, size_t sz)
+void *
+Perl_Slab_Alloc(pTHX_ int m, size_t sz)
 {
     /*
      * To make incrementing use count easy PL_OpSlab is an I32 *
@@ -74,8 +69,8 @@ S_Slab_Alloc(pTHX_ int m, size_t sz)
     return (void *)(PL_OpPtr + 1);
 }
 
-STATIC void
-S_Slab_Free(pTHX_ void *op)
+void
+Perl_Slab_Free(pTHX_ void *op)
 {
     I32 **ptr = (I32 **) op;
     I32 *slab = ptr[-1];
@@ -93,10 +88,6 @@ S_Slab_Free(pTHX_ void *op)
 	}
     }
 }
-
-#else
-#define NewOp(m, var, c, type) Newz(m, var, c, type)
-#define FreeOp(p) Safefree(p)
 #endif
 /*
  * In the following definition, the ", Nullop" is just to make the compiler
diff --git a/op.h b/op.h
index 3bf90c7..ed38438 100644
--- a/op.h
+++ b/op.h
@@ -483,3 +483,16 @@ struct loop {
 #include "reentr.h"
 #endif
 
+#if defined(PL_OP_SLAB_ALLOC)
+#define NewOp(m,var,c,type)	\
+	STMT_START {		\
+		var = (type *) Perl_Slab_Alloc(aTHX_ m,c*sizeof(type));\
+	} STMT_END
+#define NewOpSz(m,var,size)	\
+	STMT_START { var = (OP *) Perl_Slab_Alloc(aTHX_ m,size); } STMT_END
+#define FreeOp(p) Perl_Slab_Free(aTHX_ p)
+#else
+#define NewOp(m, var, c, type) Newz(m, var, c, type)
+#define NewOpSz(m, var, size) Newz(m, (char*)var, size, char)
+#define FreeOp(p) Safefree(p)
+#endif
diff --git a/proto.h b/proto.h
index e41659e..97ae843 100644
--- a/proto.h
+++ b/proto.h
@@ -981,10 +981,10 @@ STATIC OP *	S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp);
 STATIC OP *	S_dup_attrlist(pTHX_ OP *o);
 STATIC void	S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my);
 STATIC void	S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp);
-#  if defined(PL_OP_SLAB_ALLOC)
-STATIC void*	S_Slab_Alloc(pTHX_ int m, size_t sz);
-STATIC void	S_Slab_Free(pTHX_ void *op);
-#  endif
+#endif
+#if defined(PL_OP_SLAB_ALLOC)
+PERL_CALLCONV void*	Perl_Slab_Alloc(pTHX_ int m, size_t sz);
+PERL_CALLCONV void	Perl_Slab_Free(pTHX_ void *op);
 #endif
 
 #if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT)
diff --git a/t/TEST b/t/TEST
index 95869fb..5885060 100755
--- a/t/TEST
+++ b/t/TEST
@@ -246,9 +246,17 @@ EOT
 		or print "can't deparse '$deparse': $!.\n";
 	}
 	elsif ($type eq 'bytecompile') {
-	    my $perl = $ENV{PERL} || './perl';
-	    my $redir = ($^O eq 'VMS' ? '2>&1' : '');
-	    my $bswitch = "-MO=Bytecode,-H,-TI,-s`pwd`/$test,";
+	    my ($pwd, $null);
+            if( $^O eq 'MSWin32') {
+		$pwd = `cd`;
+		$null = 'nul';
+	    } else {
+		$pwd = `pwd`;
+		$null = '/dev/null';
+	    }
+	    chomp $pwd;
+	    my $perl = $ENV{PERL} || "$pwd/perl";
+	    my $bswitch = "-MO=Bytecode,-H,-TI,-s$pwd/$test,";
 	    $bswitch .= "-TF$test.plc,"
 		if $test =~ m(chdir|pod/|CGI/t/carp|lib/DB);
 	    $bswitch .= "-k,"
@@ -257,8 +265,8 @@ EOT
 		if $test =~ m(op/getpid);
 	    my $bytecompile =
 		"$perl $testswitch $switch -I../lib $bswitch". 
-		"-o$test.plc $test 2>/dev/null &&".
-		"$perl $testswitch $switch -I../lib $utf $test.plc $redir|";
+		"-o$test.plc $test 2>$null &&".
+		"$perl $testswitch $switch -I../lib $utf $test.plc |";
 	    open(RESULTS,$bytecompile)
 		or print "can't byte-compile '$bytecompile': $!.\n";
 	}