updates to compiler modules

	Message-ID: <19990303072725.779.qmail@hotmail.com>
	Subject: PATCH 5.005_56 + Test procedure

p4raw-id: //depot/perl@3066

diff --git a/MANIFEST b/MANIFEST
index 21a8f9d..4e3d504 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -170,6 +170,7 @@ ext/B/B/Disassembler.pm     Compiler Disassembler backend
 ext/B/B/Lint.pm                Compiler Lint backend
 ext/B/B/Showlex.pm     Compiler Showlex backend
 ext/B/B/Stackobj.pm    Compiler stack objects support functions
+ext/B/B/Stash.pm       Compiler module to identify stashes
 ext/B/B/Terse.pm       Compiler Terse backend
 ext/B/B/Xref.pm                Compiler Xref backend
 ext/B/B/assemble       Assemble compiler bytecode

diff --git a/cc_runtime.h b/cc_runtime.h
index 9a01ff8..5b6d2c7 100644 (file)
--- a/cc_runtime.h
+++ b/cc_runtime.h
@@ -59,13 +59,39 @@
        SPAGAIN;                                \
     } while (0)
 
-#define PP_ENTERTRY(jmpbuf,label) do {         \
-       dJMPENV;                                \
+#define B_JMPENV_PUSH(cur_env,v) \
+    STMT_START {                                        \
+        cur_env.je_prev = PL_top_env;                   \
+        OP_REG_TO_MEM;                                  \
+        cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, 1);    \
+        OP_MEM_TO_REG;                                  \
+        PL_top_env = &cur_env;                          \
+        cur_env.je_mustcatch = FALSE;                   \
+        (v) = cur_env.je_ret;                           \
+    } STMT_END
+#define B_JMPENV_POP(cur_env) \
+    STMT_START { PL_top_env = cur_env.je_prev; } STMT_END
+
+#define B_JMPENV_JUMP(cur_env,v) \
+    STMT_START {                                                \
+        OP_REG_TO_MEM;                                          \
+        if (PL_top_env->je_prev)                                        \
+            PerlProc_longjmp(PL_top_env->je_buf, (v));                  \
+        if ((v) == 2)                                           \
+            PerlProc_exit(STATUS_NATIVE_EXPORT);                                \
+        PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");     \
+        PerlProc_exit(1);                                               \
+    } STMT_END    
+
+
+#define PP_ENTERTRY(jmpbuf,label)  {           \
        int ret;                                \
-       JMPENV_PUSH(ret);                       \
+       B_JMPENV_PUSH(jmpbuf,ret);                      \
        switch (ret) {                          \
-       case 1: JMPENV_POP; JMPENV_JUMP(1);     \
-       case 2: JMPENV_POP; JMPENV_JUMP(2);     \
-       case 3: JMPENV_POP; SPAGAIN; goto label;\
-       }                                       \
+       case 1: B_JMPENV_POP(jmpbuf); B_JMPENV_JUMP(jmpbuf,1);  \
+       case 2: B_JMPENV_POP(jmpbuf); B_JMPENV_JUMP(jmpbuf,2);  \
+       case 3: B_JMPENV_POP(jmpbuf); SPAGAIN; goto label;\
+       }                                       \
     } while (0)
+
+#define PP_LEAVETRY PL_top_env=PL_top_env->je_prev

diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm
index 67b20b9..759b9cd 100644 (file)
--- a/ext/B/B/C.pm
+++ b/ext/B/B/C.pm
@@ -1301,12 +1301,6 @@ sub descend_marked_unused {
     }
 }
 
-sub descend_marked_unused {
-    foreach my $pack (keys %unused_sub_packages)
-    {
-       mark_package($pack);
-    }
-}
  
 sub save_main {
     warn "Starting compile\n";

diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm
index 08429cb..d44a119 100644 (file)
--- a/ext/B/B/CC.pm
+++ b/ext/B/B/CC.pm
@@ -8,10 +8,10 @@
 package B::CC;
 use strict;
 use B qw(main_start main_root class comppadlist peekop svref_2object
-       timing_info init_av  
+       timing_info init_av  sv_undef
        OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL
        OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV
-       OPpDEREF OPpFLIP_LINENUM G_ARRAY     
+       OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR    
        CXt_NULL CXt_SUB CXt_EVAL CXt_LOOP CXt_SUBST CXt_BLOCK
        );
 use B::C qw(save_unused_subs objsym init_sections mark_unused
@@ -444,7 +444,7 @@ sub doop {
 sub gimme {
     my $op = shift;
     my $flags = $op->flags;
-    return (($flags & OPf_WANT) ? ($flags & OPf_WANT_LIST) : "dowantarray()");
+    return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()");
 }
 
 #
@@ -459,10 +459,12 @@ sub pp_null {
 sub pp_stub {
     my $op = shift;
     my $gimme = gimme($op);
-    if ($gimme != 1) {
+    if ($gimme != G_ARRAY) {
+       my $obj= new B::Stackobj::Const(sv_undef);
+       push(@stack, $obj);
        # XXX Change to push a constant sv_undef Stackobj onto @stack
-       write_back_stack();
-       runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
+       #write_back_stack();
+       #runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
     }
     return $op->next;
 }
@@ -921,7 +923,7 @@ sub pp_list {
     my $op = shift;
     write_back_stack();
     my $gimme = gimme($op);
-    if ($gimme == 1) { # sic
+    if ($gimme == G_ARRAY) { # sic
        runtime("POPMARK;"); # need this even though not a "full" pp_list
     } else {
        runtime("PP_LIST($gimme);");
@@ -941,6 +943,20 @@ sub pp_entersub {
     invalidate_lexicals(REGISTER|TEMPORARY);
     return $op->next;
 }
+sub pp_formline {
+    my $op = shift;
+    my $ppname = $op->ppaddr;
+    write_label($op);
+    write_back_lexicals() unless $skip_lexicals{$ppname};
+    write_back_stack() unless $skip_stack{$ppname};
+    my $sym=doop($op);
+    # See comment in pp_grepwhile to see why!
+    $init->add("((LISTOP*)$sym)->op_first = $sym;");    
+    runtime("if  (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
+    runtime( sprintf("goto %s;",label($op)));
+    runtime("}");
+    return $op->next;
+}
 
 sub pp_goto{
 
@@ -996,12 +1012,19 @@ sub pp_entertry {
     write_back_stack();
     my $sym = doop($op);
     my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
-    declare("Sigjmp_buf", $jmpbuf);
+    declare("JMPENV", $jmpbuf);
     runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
     invalidate_lexicals(REGISTER|TEMPORARY);
     return $op->next;
 }
 
+sub pp_leavetry{
+       my $op=shift;
+       default_pp($op);
+       runtime("PP_LEAVETRY;");
+       return $op->next;
+}
+
 sub pp_grepstart {
     my $op = shift;
     if ($need_freetmps && $freetmps_each_loop) {

diff --git a/ext/B/B/Stash.pm b/ext/B/B/Stash.pm
new file mode 100644 (file)
index 0000000..42c8bc0
--- /dev/null
+++ b/ext/B/B/Stash.pm
@@ -0,0 +1,29 @@
+# Stash.pm -- show what stashes are loaded
+# vishalb@hotmail.com 
+package B::Stash;
+
+BEGIN { %Seen = %INC }
+
+END {
+       my @arr=scan($main::{"main::"});
+       @arr=map{s/\:\:$//;$_;}  @arr;
+       print "-umain,-u", join (",-u",@arr) ,"\n";
+}
+sub scan{
+       my $start=shift;
+       my @return;
+       foreach my $key ( keys %{$start}){
+               if ($key =~ /::$/){
+                       unless ($start  eq ${$start}{$key} or $key eq "B::" ){
+                               push @return, $key ;
+                               foreach my $subscan ( scan(${$start}{$key})){
+                                       push @return, "$key".$subscan;  
+                               }
+                       }
+               }
+       }
+       return @return;
+}
+1;
+
+

diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm
index 738f36d..71c0c1c 100644 (file)
--- a/lib/Test/Harness.pm
+++ b/lib/Test/Harness.pm
@@ -82,7 +82,7 @@ sub runtests {
        $s .= q[ "-T"] if $first =~ /^#!.*\bperl.*-\w*T/;
        $fh->close or print "can't close $test. $!\n";
        my $cmd = ($ENV{'COMPILE_TEST'})? 
-"./perl -I../lib ../utils/perlcc $test -run -verbose dcf -log ./compilelog |" 
+"./perl -I../lib ../utils/perlcc $test -run 2>> ./compilelog |" 
                                                                                                                        :  "$^X $s $test|";
        $cmd = "MCR $cmd" if $^O eq 'VMS';
        $fh->open($cmd) or print "can't run $test. $!\n";

diff --git a/utils/perlcc.PL b/utils/perlcc.PL
index b214645..2ea822b 100644 (file)
--- a/utils/perlcc.PL
+++ b/utils/perlcc.PL
@@ -223,8 +223,11 @@ sub _createCode
 
     if (@_ == 2)                                   # compiling a program   
     {
-        _print( "$^X -I@INC -MO=CC,-o$generated_cfile $file\n", 36);
-        $return =  _run("$\18 -I@INC -MO=CC,-o$generated_cfile $file", 9);
+        _print( "$^X -I@INC -MB::Stash -c  $file\n", 36);
+        my $stash=`$^X -I@INC -MB::Stash -c  $file 2>/dev/null|tail -1`;
+       chomp $stash;
+        _print( "$^X -I@INC -MO=CC,$stash,-o$generated_cfile $file\n", 36);
+        $return =  _run("$\18 -I@INC -MO=CC,$stash,-o$generated_cfile $file", 9);
         $return;
     }
     else                                           # compiling a shared object
@@ -311,9 +314,10 @@ sub _ccharness
     }
 
     my @sharedobjects = _getSharedObjects($sourceprog); 
+    my $dynaloader="$Config{'installarchlib'}/auto/DynaLoader/DynaLoader.a";
 
     my $cccmd = 
-        "$Config{cc} @Config{qw(ccflags optimize)} $incdir @sharedobjects @args $linkargs";
+        "$Config{cc} @Config{qw(ccflags optimize)} $incdir @sharedobjects @args $dynaloader $linkargs";
 
 
     _print ("$cccmd\n", 36);
@@ -558,7 +562,7 @@ sub _checkopts
                                                     && $options->{'gen'})
     {
         push(@errors, 
-"ERROR: The options '-regex', '-run', and '-o' are incompatible with '-gen'. 
+"ERROR: The options '-regex', ' -c -run', and '-o' are incompatible with '-gen'. 
        '-gen' says to stop at C generation, and the other three modify the 
        compilation and/or running process!\n");
     }