ghc/driver/ghc-iface.lprl

   1 %************************************************************************
   2 %*                                                                      *
   3 \section[Driver-iface-thing]{Interface-file handling}
   4 %*                                                                      *
   5 %************************************************************************
   6
   7 \begin{code}
   8 %OldVersion = ();
   9 %Decl    = (); # details about individual definitions
  10 %Stuff   = (); # where we glom things together
  11 %HiExists      = ('old',-1,  'new',-1); # 1 <=> definitely exists; 0 <=> doesn't
  12 %HiHasBeenRead = ('old', 0,  'new', 0);
  13 %ModuleVersion = ('old', 0,  'new', 0);
  14
  15 %HiSections = ();
  16
  17 sub postprocessHiFile {
  18     local($hsc_hi,              # The iface info produced by hsc.
  19           $hifile_target,       # The name both of the .hi file we
  20                                 # already have and which we *might*
  21                                 # replace.
  22           $going_interactive) = @_;
  23
  24     local($new_hi) = "$Tmp_prefix.hi-new";
  25     local($show_hi_diffs) = $HiDiff_flag && ! $HiOnStdout && ! $going_interactive && -f $hifile_target;
  26
  27     print STDERR "*** New hi file follows...\n" if $Verbose;
  28     system("$Cat $hsc_hi 1>&2") if $Verbose;
  29
  30     &constructNewHiFile($hsc_hi, *hifile_target, $new_hi, $show_hi_diffs);
  31
  32     # run diff if they asked for it
  33     if ($show_hi_diffs) {
  34         if ( $HiDiff_flag eq 'usages' ) {
  35             # lots of near-useless info; but if you want it...
  36             &run_something("$Cmp -s $hifile_target $new_hi || $Diff $hifile_target $new_hi 1>&2 || exit 0",
  37                 "Diff'ing old and new .$HiSuffix files"); # NB: to stderr
  38         } else {
  39             # strip out usages, *then* run diff
  40             local($hi_before) = "$Tmp_prefix.hi-before";
  41             local($hi_after)  = "$Tmp_prefix.hi-now";
  42
  43             &deUsagifyHi($hifile_target, $hi_before);
  44             &deUsagifyHi($new_hi,        $hi_after);
  45
  46             &run_something("$Cmp -s $hi_before $hi_after || $Diff $hi_before $hi_after 1>&2 || exit 0",
  47                 "Diff'ing old and new .$HiSuffix files"); # NB: to stderr
  48         }
  49     }
  50
  51     # if we produced an interface file "no matter what",
  52     # print what we got on stderr (ToDo: honor -ohi flag)
  53     if ( $HiOnStdout ) {
  54         if ( $HiWith ne '' ) {
  55             # output some of the sections
  56             local($hi_after)  = "$Tmp_prefix.hi-now";
  57
  58             foreach $hi ( split(' ',$HiWith) ) {
  59                 $HiSection{$hi} = 1;
  60             }
  61             &hiSectionsOnly($new_hi, $hi_after);
  62
  63             system("$Cat $hi_after 1>&2 ; $Rm $hi_after; ");
  64         } else {
  65             system("$Cat $new_hi 1>&2");
  66         }
  67     } else {
  68         &run_something("$Cmp -s $hifile_target $new_hi || ( $Rm $hifile_target && $Cp $new_hi $hifile_target )",
  69            "Replace .$HiSuffix file, if changed");
  70     }
  71 }
  72
  73 sub deUsagifyHi {
  74     local($ifile,$ofile) = @_;
  75
  76     open(OLDHIF, "< $ifile") || &tidy_up_and_die(1,"Can't open $ifile (read)\n");
  77     open(NEWHIF, "> $ofile") || &tidy_up_and_die(1,"Can't open $ofile (write)\n");
  78
  79     # read up to _usages_ line
  80     $_ = <OLDHIF>;
  81     while ($_ ne '' && ! /^_usages_/) {
  82         print NEWHIF $_ unless /^(_interface_ |\{-# GHC_PRAGMA)/;
  83         $_ = <OLDHIF>;
  84     }
  85     if ( $_ ne '' ) {
  86         # skip to next _<anything> line
  87         $_ = <OLDHIF>;
  88         while ($_ ne '' && ! /^_/) { $_ = <OLDHIF>; }
  89
  90         # print the rest
  91         while ($_ ne '') {
  92             print NEWHIF $_;
  93             $_ = <OLDHIF>;
  94         }
  95     }
  96
  97     close(OLDHIF) || &tidy_up_and_die(1,"Failed reading from $ifile\n");
  98     close(NEWHIF) || &tidy_up_and_die(1,"Failed writing to $ofile\n");
  99 }
 100
 101 sub hiSectionsOnly {
 102     local($ifile,$ofile) = @_;
 103
 104     open(OLDHIF, "< $ifile") || &tidy_up_and_die(1,"Can't open $ifile (read)\n");
 105     open(NEWHIF, "> $ofile") || &tidy_up_and_die(1,"Can't open $ofile (write)\n");
 106
 107     # read up to _usages_ line
 108     $_ = <OLDHIF>;
 109     while ($_ ne '' ) {
 110         if ( /^_(.*)_/ && $HiSection{$1} )  {
 111              do { print NEWHIF $_;
 112                   $_ = <OLDHIF>;} until ($_ eq '' || /^_/ );
 113         } else {
 114           $_ = <OLDHIF>;
 115         }
 116     }
 117
 118     close(OLDHIF) || &tidy_up_and_die(1,"Failed reading from $ifile\n");
 119     close(NEWHIF) || &tidy_up_and_die(1,"Failed writing to $ofile\n");
 120 }
 121 \end{code}
 122
 123 \begin{code}
 124 sub constructNewHiFile {
 125     local($hsc_hi,          # The iface info produced by hsc.
 126           *hifile_target,   # Pre-existing .hi filename (if it exists)
 127           $new_hi,          # Filename for new one
 128           $show_hi_diffs) = @_;
 129     local($hiname,$hidir);
 130
 131     &readHiFile('new',$hsc_hi)        unless $HiHasBeenRead{'new'} == 1;
 132     if ($Specific_hi_file eq '') {  # -ohi is used even if  module name != stem of filename.
 133         ($hiname = $hifile_target) =~ s/([^\/]*\/)*(.*)\.$HiSuffix/$2/;
 134         if ($ModuleName{'new'} ne $hiname) {
 135           ($hidir  = $hifile_target) =~ s/([^\/]*\/)*.*\.$HiSuffix/$1/;
 136           $hifile_target = $hidir . $ModuleName{'new'} . ".$HiSuffix";
 137         }
 138     }
 139     &readHiFile('old',$hifile_target) unless $HiHasBeenRead{'old'} == 1;
 140
 141     open(NEWHI, "> $new_hi") || &tidy_up_and_die(1,"Can't open $new_hi (write)\n");
 142
 143     local(@decl_names) = ();    # Entities in _declarations_ section of new module
 144     foreach $v (sort (keys %Decl)) {
 145         next unless $v =~ /^new:(.*$)/;
 146         push(@decl_names,$1);
 147     }
 148
 149     local($new_module_version) = &calcNewModuleVersion(@decl_names);
 150     print NEWHI "_interface_ ", $ModuleName{'new'}, " $new_module_version $ProjectVersionInt\n";
 151
 152     if ( $Stuff{'new:instance_modules'} ) {
 153         print NEWHI "_instance_modules_\n";
 154         print NEWHI $Stuff{'new:instance_modules'};
 155     }
 156
 157     print NEWHI "_usages_\n", $Stuff{'new:usages'} unless $Stuff{'new:usages'} eq '';
 158
 159     print NEWHI "_exports_\n";
 160     print NEWHI $Stuff{'new:exports'};
 161
 162     if ( $Stuff{'new:fixities'} ) {
 163         print NEWHI "_fixities_\n";
 164         print NEWHI $Stuff{'new:fixities'};
 165     }
 166
 167     if ( $Stuff{'new:instances'} ) {
 168         print NEWHI "_instances_\n";
 169         print NEWHI $Stuff{'new:instances'};
 170     }
 171
 172     print NEWHI "_declarations_\n";
 173     foreach $v (@decl_names) {
 174         &printNewItemVersion(NEWHI, $v, $new_module_version, $show_hi_diffs);           # Print new version number
 175         print NEWHI $Decl{"new:$v"};            # Print the new decl itself
 176     }
 177
 178
 179
 180     close(NEWHI) || &tidy_up_and_die(1,"Failed writing to $new_hi\n");
 181 }
 182 \end{code}
 183
 184 Read the .hi file made by the compiler, or the old one.
 185 All the declarations in the file are stored in
 186
 187         $Decl{"$mod:$v"}
 188
 189 where $mod is "new" or "old", depending on whether it's the new or old
 190         .hi file that's being read.
 191
 192 and $v is
 193         for values v    "v"
 194         for tycons T    "type T" or "data T"
 195         for classes C   "class C"
 196
 197
 198 \begin{code}
 199 sub readHiFile {
 200     local($mod,             # module to read; can be special tag 'old'
 201                             # (old .hi file for module being compiled) or
 202                             # 'new' (new proto-.hi file for...)
 203           $hifile) = @_;    # actual file to read
 204
 205     # info about the old version of this module's interface
 206     $HiExists{$mod}      = -1; # 1 <=> definitely exists; 0 <=> doesn't
 207     $HiHasBeenRead{$mod} = 0;
 208     $ModuleVersion{$mod} = 0;
 209     $Stuff{"$mod:instance_modules"} = '';
 210     $Stuff{"$mod:usages"}           = ''; # stuff glommed together
 211     $Stuff{"$mod:exports"}          = '';
 212     $Stuff{"$mod:fixities"}         = '';
 213     $Stuff{"$mod:instances"}        = '';
 214     $Stuff{"$mod:declarations"}     = '';
 215
 216     if (! -f $hifile) { # no pre-existing .hi file
 217         $HiExists{$mod} = 0;
 218         return();
 219     }
 220
 221     open(HIFILE, "< $hifile") || &tidy_up_and_die(1,"Can't open $hifile (read)\n");
 222     $HiExists{$mod} = 1;
 223     local($now_in) = '';
 224     hi_line: while (<HIFILE>) {
 225         next if /^ *$/; # blank line
 226         next if /\{-# GHC_PRAGMA INTERFACE VERSION 20 #-\}/;
 227
 228         # avoid pre-1.3 interfaces
 229         #print STDERR "now_in:$now_in:$_";
 230         if ( /\{-# GHC_PRAGMA INTERFACE VERSION . #-\}/ ) {
 231             $HiExists{$mod} = 0;
 232             last hi_line;
 233         }
 234
 235         if ( /^_interface_ ([A-Z]\S*) (\d+)/ && $mod ne 'new' ) {
 236             $ModuleName{$mod}    = $1; # used to decide name of interface file.
 237             $ModuleVersion{$mod} = $2;
 238
 239         } elsif ( /^_interface_ ([A-Z]\S*) (\d+)/ && $mod eq 'new' ) { # special case: no version
 240             $ModuleName{'new'} = $1;
 241
 242         } elsif ( /^_([a-z_]+)_$/ ) {
 243             $now_in = $1;
 244
 245         } elsif ( $now_in eq 'usages' && /^(\S+)\s+(!\s+)?(\d+)\s+::(.*)/ ) {
 246             $Stuff{"$mod:usages"} .= $_; # save the whole thing
 247
 248
 249         } elsif ( $now_in =~ /^(exports|instance_modules|instances|fixities)$/ ) {
 250             $Stuff{"$mod:$1"} .= $_; # just save it up
 251
 252         } elsif ( /^--.*/ ) { # silently ignore comment lines.
 253             ;
 254         } elsif ( $now_in eq 'declarations' ) { # relatively special treatment needed...
 255         # We're in a declaration
 256
 257         # Strip off the initial version number, if any
 258            if ( /^([0-9]+) (.*\n)/ ) {
 259                 # The "\n" is because we need to keep the newline at the end, so that
 260                 # it looks the same as if there's no version number and this if statement
 261                 # doesn't fire.
 262
 263                 # So there's an initial version number
 264                 $version = $1;
 265                 $_ = $2;
 266            }
 267
 268             if ( /^(\S+)\s+_:_\s+/ ) {
 269                         # Value declaration
 270                 $current_name = $1;
 271                 $Decl{"$mod:$current_name"} = $_;
 272                 if ($mod eq "old") { $OldVersion{$current_name} = $version; }
 273
 274             } elsif ( /^type\s+(\S+)/ ) {
 275                         # Type declaration
 276                 $current_name = "type $1";
 277                 $Decl{"$mod:$current_name"} = $_;
 278                 if ($mod eq "old") { $OldVersion{$current_name} = $version; }
 279
 280             } elsif ( /^(newtype|data)\s+(.*\s+=>\s+)?(\S+)\s+/ ) {
 281                         # Data declaration
 282                 $current_name = "data $3";
 283                 $Decl{"$mod:$current_name"} = $_;
 284                 if ($mod eq "old") { $OldVersion{$current_name} = $version; }
 285
 286             } elsif ( /^class\s+(\{[^{}]*\}\s+=>\s+)?(\S+)\s+/ ) {
 287                         # Class declaration
 288                 # must be wary of => bit matching after "where"...
 289                 # ..hence the [^{}] part
 290                 # NB: a class decl may not have a where part at all
 291                 $current_name = "class $2";
 292                 $Decl{"$mod:$current_name"} = $_;
 293                 if ($mod eq "old") { $OldVersion{$current_name} = $version; }
 294
 295             } else { # Continuation line
 296                 $Decl{"$mod:$current_name"} .= $_
 297             }
 298
 299         } else {
 300             print STDERR "$Pgm:junk old iface line?:section:$now_in:$_";
 301         }
 302     }
 303
 304 #   foreach $i ( sort (keys %Decl)) {
 305 #       print STDERR "$i: ",$Decl{$i}, "\n";
 306 #   }
 307
 308     close(HIFILE) || &tidy_up_and_die(1,"Failed reading from $hifile\n");
 309     $HiHasBeenRead{$mod} = 1;
 310 }
 311 \end{code}
 312
 313 \begin{code}
 314 sub calcNewModuleVersion {
 315     local (@decl_names) = @_;
 316
 317     return(&mv_change(1,'no old .hi file')) if $HiExists{'old'} == 0;
 318         # could use "time()" as initial version; if a module existed, then was deleted,
 319         # then comes back, we don't want the resurrected one to have an
 320         # lower version number than the original (in case there are any
 321         # lingering references to the original in other .hi files).
 322
 323     local($unchanged_version) = $ModuleVersion{'old'}; # will return one of these two
 324     local($changed_version)   = $unchanged_version + 1;
 325
 326 # This statement is curious; it is subsumed by the foreach!
 327 #    return(&mv_change($changed_version,'usages changed')) if $Stuff{'old:usages'} ne $Stuff{'new:usages'};
 328
 329     foreach $t ( 'usages' , 'exports', 'instance_modules', 'instances', 'fixities' ) {
 330         return(&mv_change($changed_version,"$t changed")) if $Stuff{"old:$t"} ne $Stuff{"new:$t"};
 331     }
 332
 333 # Decl need separate treatment; they aren't in $Stuff
 334     foreach $v (@decl_names) {
 335         return(&mv_change($changed_version,"$v changed")) if $Decl{"old:$v"} ne $Decl{"new:$v"};
 336     }
 337
 338     print STDERR "$Pgm: module version unchanged at $unchanged_version\n";
 339     return($unchanged_version);
 340 }
 341
 342 sub mv_change {
 343     local($mv, $str) = @_;
 344
 345     print STDERR "$Pgm: module version changed to $mv; reason: $str\n";
 346     return($mv);
 347 }
 348
 349 sub printNewItemVersion {
 350     local($hifile, $item, $mod_version, $show_hi_diffs) = @_;
 351     local($idecl) = $Decl{"new:$item"};
 352
 353
 354     if (! defined($Decl{"old:$item"})) {        # Old decl doesn't exist
 355         if ($show_hi_diffs) {print STDERR "new: $item\n";}
 356         print $hifile  "$mod_version ";         # Use module version
 357
 358     } elsif (! defined($OldVersion{"$item"}) ) {
 359         if ($show_hi_diffs) {print STDERR "$item: no old version?!\n";}
 360         print $hifile  "$mod_version ";                 # Use module version
 361
 362     } elsif ($idecl ne $Decl{"old:$item"})  {   # Old decl differs from new decl
 363         local($odecl) = $Decl{"old:$item"};
 364         if ($show_hi_diffs) {print STDERR "changed: $item\nOld: $odecl", "New: $idecl";}
 365         print $hifile  "--old: ", $OldVersion{"$item"}, " $odecl"
 366                         if $Keep_HiDiffs;         # show old in interface file
 367         print $hifile  "$mod_version ";           # Use module version
 368
 369     } else {                                    # Identical decls, so use old version number
 370         #if ($show_hi_diffs) {print STDERR "$item: unchanged\n";}
 371         print $hifile  $OldVersion{"$item"}, " ";
 372     }
 373     return;
 374 }
 375 \end{code}
 376
 377 \begin{code}
 378 # make "require"r happy...
 379 1;
 380 \end{code}