PERL   121
upcr ctuple pl
Guest on 13th March 2023 12:16:04 AM


  1. use strict;
  2.  
  3. # extract embedded keywords from binary UPC/Gasnet file
  4. {
  5.   my %ctuple_cache;
  6.   sub extract_ctuples
  7.   {
  8.     my ($filename) = @_;
  9.     my (%gasnet_ctuples, %upcr_ctuples, %upcr_sizes, %misc_info);
  10.  
  11.     if (exists $ctuple_cache{$filename}) {
  12.       return @{$ctuple_cache{$filename}};
  13.     }
  14.  
  15.     # Try to use .ct cachefile for lib.a unless mtime is older
  16.     my $cachefile = $filename;
  17.     if (!($cachefile =~ s/\.a$/.ct/) ||
  18.         ((stat($filename))[9] > (stat($cachefile))[9]) ||
  19.         !open(FILE, $cachefile)) {
  20.       open (FILE, $filename) or die "can't open file '$filename'\n";
  21.     }
  22.  
  23.     # use $ as the line break symbol, to make grepping for ident-style strings
  24.     # simpler and more efficient.
  25.     local $/ = '$';
  26.     while (<FILE>) {
  27.       my $c = substr($_,0,1);
  28.       next unless ($c eq 'G' || $c eq 'U'); # Reject most lines quickly
  29.       if (/^GASNet/) { # Divide ...
  30.         if (/^GASNetConfig:
  31.                   \s+
  32.                   \( ([^)]+) \)                     # $1: filename (in parens)
  33.                   \s+
  34.                   ([^\$]+?)                         # $2: config string
  35.                   \ \$                              # space followed by $
  36.             /x)
  37.         {
  38.             $gasnet_ctuples{$1} = $2;
  39.         } elsif (/^(GASNet\S+): \s+                 # $1: other misc UPCR ident string
  40.                   ([^\$]+)                          # $2: value
  41.                   \ \$                              # space followed by $
  42.                 /x) {
  43.             $misc_info{$1} = $2;
  44.         }
  45.       } elsif (/^UPC/) { # ... and conquer.
  46.         if (/^UPCRConfig:
  47.                   \s+
  48.                   \( ([^)]+) \)                     # $1: filename (in parens)
  49.                   \s+
  50.                   ([^\$]+?)                         # $2: config string
  51.                   \ \$                              # space followed by $
  52.             /x)
  53.         {
  54.             $upcr_ctuples{$1} = $2;
  55.         } elsif (/^UPCRSizeof: \s+
  56.                       ([A-Za-z0-9_]+)               # $1: type
  57.                       =
  58.                       ([\%-~])                      # char in %...~ range
  59.                       \ \$
  60.                  /x) {
  61.                 # subtract ASCII '$' from '%...~' to get 1...90 size
  62.                 $upcr_sizes{$1} = ord($2) - ord('$');
  63.         } elsif (/^UPCRDefaultHeapSizes: \s+
  64.                       UPC_SHARED_HEAP_OFFSET=([0-9]+[A-Za-z]*)
  65.                       \s+
  66.                       UPC_SHARED_HEAP_SIZE=([0-9]+[A-Za-z]*)
  67.                       (?: \s+
  68.                           UPC_SHARED_HEAP_SIZE_MAX=([0-9]+[A-Za-z]*) )?
  69.                       \ \$
  70.                  /x) {
  71.                 $upcr_sizes{UPC_SHARED_HEAP_OFFSET} = $1;
  72.                 $upcr_sizes{UPC_SHARED_HEAP_SIZE} = $2;
  73.                 $upcr_sizes{UPC_SHARED_HEAP_SIZE_MAX} = $3 if ($3);
  74.         } elsif (/^UPCRDefaultPthreadCount: \s+
  75.                   ([0-9]+)                          # $1: count
  76.                   \ \$                              # space followed by $
  77.                 /x) {
  78.                 $misc_info{DefaultPthreadCount}{'<link>'} = $1;
  79.         } elsif (/^(UPC\S+): \s+                    # $1: other misc UPCR per-file ident string
  80.                   \( ([^)]+) \)                     # $2: filename (in parens)
  81.                   \s+
  82.                   ([^\$]+?)                         # $3: value
  83.                   \ \$                              # space followed by $
  84.                 /x) {
  85.                 $misc_info{$1}{$2} = $3;
  86.         } elsif (/^(UPCR\S+): \s+                   # $1: other misc UPCR ident string
  87.                   ([^\$]+)                          # $2: value
  88.                   \ \$                              # space followed by $
  89.                 /x) {
  90.             $misc_info{$1} = $2;
  91.         }
  92.       }
  93.     }
  94.     close (FILE);
  95.  
  96.     # return by ref to avoid flattening
  97.     my @result = (\%gasnet_ctuples, \%upcr_ctuples, \%upcr_sizes, \%misc_info);
  98.     $ctuple_cache{$filename} = \@result;
  99.     return @result;
  100.   }
  101. }
  102.  
  103. # check a .trans.c source file contains the proper ctuple strings
  104. sub check_ctuple_trans
  105.  
  106. {
  107.     my $filename = $_[0];
  108.     open (TRANS_FILE, $filename) or die "could not read $filename: $!\n";
  109.     my $oldsep = $/;
  110.     undef $/;                # open maw
  111.     my $transtxt = <TRANS_FILE>; # slurp!
  112.     $/ = $oldsep;            # close maw
  113.     close TRANS_FILE;
  114.  
  115.     unless (
  116.      ($transtxt =~ m/UPCRI_IdentString_.*_GASNetConfig_gen/) &&
  117.      ($transtxt =~ m/UPCRI_IdentString_.*_GASNetConfig_obj/) &&
  118.      ($transtxt =~ m/UPCRI_IdentString_.*_UPCRConfig_gen/) &&
  119.      ($transtxt =~ m/UPCRI_IdentString_.*_UPCRConfig_obj/)  
  120.     ) { die "file $filename is missing mandatory configuration strings!\n"; }
  121. }
  122.  
  123. # Check the consistency of a UPC object by comparing its configuration tuples,
  124. # both internally and optionally with a canonical model
  125. {
  126.  my $mismatch_warned = 0;
  127.  my $dynamic_warned = 0;
  128.  sub check_ctuple_obj {
  129.     my ($filename, $allow_missing, $canon_gasnet, $canon_upcr) = @_;
  130.     my ($gasnet_ctuples, $upcr_ctuples, $upcr_sizes, $misc_info) = extract_ctuples($filename);
  131.     my @ctup = (%$gasnet_ctuples,%$upcr_ctuples);
  132.     my $upofile = 1 unless $filename =~ m/.*_startup_tmp.o$/;
  133.     sub strdiff($$) {
  134.       my ($a,$b) = @_;
  135.       return "" if ($a eq $b);
  136.       my $cnt = str_prefix_matchlen($a,$b);
  137.       return " " . (" " x $cnt)."^\n";
  138.     }
  139.     sub dynamic_vs_static($$) {
  140.       # If obj is dynamic-threads but link is static then rewrite obj to match
  141.       my ($obj_ctup, $link_ctup) = @_;
  142.       my $link_thr = substr($link_ctup, rindex($link_ctup, ','));
  143.       if (($link_thr ne ',dynamicthreads') && $obj_ctup =~ s/,dynamicthreads$/$link_thr/) {
  144.         printf STDERR "upcc: warning: Linking dynamic-threads object into static-threads executable.\n".
  145.                       " This is supported by Berkeley UPC, but may not be portable.\n"
  146.             unless ($dynamic_warned);
  147.         $dynamic_warned = 1;
  148.       }
  149.       return $obj_ctup;
  150.     }
  151.     if (@ctup == 0 && $allow_missing) {
  152.         return 0;  # not a UPC object: presumably C object
  153.     }
  154.     if (($upofile && @ctup != 8) || (!$upofile && @ctup != 4)) {
  155.         return "missing build config strings in '${filename}'\n";
  156.     }
  157.     if ($upofile) {
  158.         # Get uniform ordering (.trans.c before .o) independent of hash ordering.
  159.         # This ordering is assumed in dynamic_vs_static() call w/ pthreads,
  160.         # and additionally provides for consistency in error outputs.
  161.         @ctup[0..3] = @ctup[2,3,0,1] unless ($ctup[0] =~ m/\.trans\.c$/);
  162.         @ctup[4..7] = @ctup[6,7,4,5] unless ($ctup[4] =~ m/\.trans\.c$/);
  163.     }
  164.     if ($upofile) {
  165.         # Allow dynamic-threads .trans.c in a static-threads link,
  166.         # but ONLY for the delayed compilation of pthreaded objects.
  167.         my $temp_ctup = ($ctup[7] =~ m/,SHMEM=pthreads/)
  168.             ? dynamic_vs_static($ctup[5], $ctup[7]) : $ctup[5];
  169.  
  170.         return "inconsistent build configuration in '${filename}':\n" .
  171.                $ctup[0] . ":\n " . $ctup[1] . "\n" .
  172.                $ctup[2] . ":\n " . $ctup[3] . "\n" . strdiff($ctup[1],$ctup[3]) .
  173.                $ctup[4] . ":\n " . $ctup[5] . "\n" .
  174.                $ctup[6] . ":\n " . $ctup[7] . "\n" . strdiff($ctup[5],$ctup[7])
  175.             unless (($ctup[1] eq $ctup[3]) && ($temp_ctup eq $ctup[7]));
  176.     }
  177.     if ($canon_upcr) {
  178.         # Allow dynamic-threads obj in a static-threads link
  179.         my $temp_ctup = dynamic_vs_static($ctup[@ctup - 1], $canon_upcr);
  180.  
  181.         return   "UPCR build configuration in '${filename}':\n" .
  182.                  " " . $ctup[@ctup - 1] . "\n" .
  183.                  "doesn't match link configuration:\n" .
  184.                  " $canon_upcr\n" . strdiff($ctup[@ctup - 1], $canon_upcr)
  185.             unless ($temp_ctup eq $canon_upcr);
  186.     }
  187.     if ($canon_gasnet && $ctup[1] ne $canon_gasnet) {
  188.         return   "GASNet build configuration in '${filename}':\n" .
  189.                  " " . $ctup[1] . "\n" .
  190.                  "doesn't match link configuration:\n" .
  191.                  " $canon_gasnet\n" . strdiff($ctup[1],$canon_gasnet);
  192.     }
  193.  
  194.     if ($$misc_info{UPCRConfigureMismatch} && !$mismatch_warned &&
  195.         $ctup[@ctup - 1] !~ /,TRANS=(g(cc)?|clang)upc,/) { # bug 1853
  196.        foreach my $filen (keys %{$$misc_info{UPCRConfigureMismatch}}) {
  197.          my $comppath = $$misc_info{UPCRBackendCompiler}{$filen} || "*unknown path*";
  198.          my $buildcomp = $$misc_info{UPCRBuildCompiler}{$filen} || "*unknown id*";
  199.          my $confcomp = $$misc_info{UPCRConfigureCompiler}{$filen} || "*unknown id*";
  200.          $comppath = upcc_decode($comppath);
  201.          print STDERR "upcc: warning: Configuration mismatch detected!\n".
  202.                       " This install of Berkeley UPC was configured with backend C compiler '$comppath', which was identified as:\n".
  203.                       "   $confcomp\n".
  204.                       " However this C compiler now identifies as:\n".
  205.                       "   $buildcomp\n".
  206.                       " This usually indicates the C compiler was changed/upgraded and UPC was not reinstalled. ".
  207.                     "Berkeley UPC is a source-to-source compilation system, and is therefore sensitive to details of the C compiler setup, even after installation. This configure/use mismatch is likely to cause correctness/performance problems - please re-configure and re-install Berkeley UPC with the new C compiler.\n";
  208.          $mismatch_warned = 1; # warn at most once per compile
  209.          last;
  210.        }
  211.     }
  212.     return undef;
  213.  }
  214. }
  215.  
  216. 1;
Raw Paste

Login or Register to edit or fork this paste. It's free.