util/gen_prelude.pl

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use IPC::Open2;
   5 use Getopt::Long;
   6 use Config ();
   7
   8 # helper code to inline the Standard Prelude in pugs.
   9
  10 # Sets up either the inlined Perl 6 source Prelude fallback, or a real
  11 # precompiled AST of Prelude.pm.
  12
  13 our %Config;
  14 our $TEMP_PRELUDE = "Prelude.pm"; # XXX: move this to config.yml?
  15 END { unlink $TEMP_PRELUDE unless $Config{keep} };
  16
  17 GetOptions \%Config, qw(--inline --pugs|p=s --precompile|i=s@ --verbose|v --touch --output|o=s --keep|k);
  18
  19 touch() if $Config{touch};
  20
  21 setup_output();
  22
  23 inline(), exit 0 if $Config{inline};
  24 precomp(), exit 0 if $Config{precompile};
  25 usage();
  26 exit 1;
  27
  28 sub setup_output {
  29     if ($Config{output}) {
  30         open OUT, "> $Config{output}" or
  31             die "open: $Config{output}: $!";
  32     } else {
  33         *OUT = *STDOUT;
  34     }
  35     binmode OUT;
  36 }
  37
  38 # XXX: with yaml precompilation, this may be bogus.
  39 sub touch {
  40     # XXX: *ugly* hack! ghc doesn't spot that the include file was changed,
  41     #      so we need to mark as stale some obj files to trigger a rebuild.
  42     #      The alternative seems to be to delete them *and* the pugs
  43     #      executable.
  44     print STDERR "Triggering rebuild... " if $Config{verbose};
  45     unlink "blib6/lib/Prelude.pm.bin";
  46     unlink "blib6/lib/Prelude.pm.bin.pm";
  47     #unlink "src/Pugs/PreludePC.hs";
  48     #unlink "src/Pugs/Run.hi";
  49     #unlink "src/Pugs/Run.o";
  50     #unlink "dist/build/Pugs/Run.hi";
  51     #unlink "dist/build/Pugs/Run.o";
  52     #unlink "dist/build/src/Pugs/Run.hi";
  53     #unlink "dist/build/src/Pugs/Run.o";
  54     #unlink "pugs$Config::Config{_exe}";
  55     print STDERR "done.\n" if $Config{verbose};
  56 }
  57
  58 sub inline {
  59     print STDERR "Generating inlined source Prelude... " if $Config{verbose};
  60
  61     gen_source($TEMP_PRELUDE);
  62     open IN, $TEMP_PRELUDE or
  63         die "Couldn't open temp prelude ($TEMP_PRELUDE): $!";
  64     my $program = do { local $/; <IN> };
  65     close IN;
  66
  67     strip_comments($program);
  68     $program =~ s{(["\\])}{\\$1}g;
  69     $program =~ s{\r?\n}{\\n" ++\n "}g;
  70
  71     print OUT <<'.';
  72 {-# LANGUAGE ForeignFunctionInterface #-}
  73 module Pugs.Prelude where
  74 import Foreign.C.String
  75 import Data.ByteString.Unsafe (unsafePackCStringLen)
  76 import System.IO.Unsafe
  77 import qualified Data.ByteString as S
  78 import qualified Data.ByteString.Lazy as L
  79
  80 {-
  81     Prelude bootstap.
  82
  83 >   The world was young, the mountains green,
  84 >   No stain yet on the Moon was seen,
  85 >   No words were laid on stream or stone,
  86 >   When Durin woke and walked alone.
  87
  88 -}
  89
  90 ----------------------------------------------------------------
  91 -- Do not modify this file; it is generated automatically by  --
  92 --                  util/gen_prelude.pl                       --
  93 ----------------------------------------------------------------
  94
  95 {-# NOINLINE preludeByteString #-}
  96 preludeByteString :: S.ByteString
  97 preludeByteString = unsafePerformIO $ unsafePackCStringLen (text__prelude_pm, size__prelude_pm)
  98
  99 preludeByteStringLazy :: L.ByteString
 100 preludeByteStringLazy = L.fromChunks [preludeByteString]
 101
 102 {-# NOINLINE testByteString #-}
 103 testByteString :: S.ByteString
 104 testByteString = unsafePerformIO $ unsafePackCStringLen (text__test_pm, size__test_pm)
 105
 106 testByteStringLazy :: L.ByteString
 107 testByteStringLazy = L.fromChunks [testByteString]
 108
 109 foreign import ccall unsafe "text__prelude_pm"
 110     text__prelude_pm :: CString
 111 foreign import ccall unsafe "size__prelude_pm"
 112     size__prelude_pm :: Int
 113
 114 foreign import ccall unsafe "text__test_pm"
 115     text__test_pm :: CString
 116 foreign import ccall unsafe "size__test_pm"
 117     size__test_pm :: Int
 118
 119 preludeStr :: String
 120 .
 121     print OUT qq<preludeStr = "$program"\n\n>;
 122     close OUT;
 123
 124     print STDERR "done.\n" if $Config{verbose};
 125 }
 126
 127 # concatenate source files. hardcode special treatment to the Prelude,
 128 # which is assumed to be the first module in the list.
 129 sub gen_source {
 130     my($target) = @_;
 131     open my $ofh, ">", $target or die "open: $target: $!";
 132
 133     my @import_lines;
 134     {
 135         my $prelude = shift @{ $Config{precompile} };
 136         warn "*** warning: Prelude.pm should probably be the first --include\n"
 137             unless $prelude =~ /Prelude/;
 138         open my $ifh, $prelude or die "open: $prelude: $!";
 139         while (<$ifh>) {
 140             if (/^\s*use (?!v6\b)(\S+)/) {
 141                 push @import_lines, $_;
 142                 my $file = $1;
 143                 my $dir = "ext/$1/lib";
 144                 $dir =~ s{::}{-}g;
 145                 $file =~ s{::}{/}g;
 146                 my $pathname = "$dir/$file.pm";
 147                 die "Cannot find $pathname" unless -e $pathname;
 148                 push @{ $Config{precompile} ||= [] }, $pathname;
 149                 next;
 150             }
 151             last if /^=begin\s+END\s*$/;
 152             print $ofh $_;
 153         }
 154     }
 155
 156     # manhandle the rest of the inlined modules.
 157     # we make a guess about what to put in %*INC. it's not perfect.
 158     # When module return values are specced, we can make this much
 159     # less hacky :-)
 160     my %seen;
 161     for my $file (@{ $Config{precompile} }) {
 162         next if $seen{$file}++; # Do not precompile duplicate entries
 163
 164         my $module; # guess what to put in %*INC
 165         open my $ifh, $file or die "open: $file: $!";
 166
 167         print $ofh "\n{\n";
 168         my $program;
 169         while (<$ifh>) {
 170             $module ||= $1 if /^(?:package|module|class) \s+ ([^-;]+)/x;
 171             $program .= $_;
 172         }
 173
 174         die "could not guess module name: $file" unless $module;
 175
 176         strip_comments($program);
 177         print $ofh $program;
 178
 179         print STDERR ", $module" if $Config{verbose};
 180         #$module =~ s#::#/#g;
 181         print $ofh "\n};\nBEGIN { %*INC<${module}> = '<precompiled>' };\n\n";
 182         # (the need for a semicolon in "};" is probably a bug.)
 183     }
 184     # print $ofh @import_lines;
 185     print STDERR "... " if $Config{verbose};
 186 }
 187
 188 # Strip comments and docs while preserving the line counts
 189 sub strip_comments {
 190     $_[0] =~ s{^[ \t]*#.*}{}mg;
 191     $_[0] =~ s{^=\w(.*?)^=cut$}{"\n" x ($1 =~ y/\n//)}mesg;
 192 }
 193
 194 sub precomp {
 195     my $output = '';
 196     if ($Config{output}) {
 197         $output = "> $Config{output}";
 198     }
 199
 200     if ($Config{verbose}) {
 201         print STDERR "# $Config{pugs} -Iext/Math-Basic/lib -C Parse-Binary $TEMP_PRELUDE $output\n";
 202         print STDERR "Generating precompiled Prelude";
 203     }
 204
 205     die "*** Error: $0 needs an already compiled Pugs to precompile the Prelude\n"
 206         unless $Config{pugs};
 207     gen_source($TEMP_PRELUDE);
 208     $ENV{PUGS_COMPILE_PRELUDE} = 1;
 209
 210     close OUT;
 211
 212     system("$Config{pugs} -Iext/Math-Basic/lib -C Parse-Binary $TEMP_PRELUDE $output");
 213
 214     if ($Config{output}) {
 215         open IN, '<:crlf', $Config{output} or die "No output found";
 216         my @lines = <IN> or do {
 217             close IN;
 218             unlink $Config{output};
 219             die "Output is empty";
 220         };
 221         close IN;
 222         open OUT, '>:raw', $Config{output} or die "Cannot write back to output";
 223         print OUT @lines;
 224         close OUT;
 225     }
 226
 227     die "Pugs ".(($?&255)?"killed by signal $?"
 228          :"exited with error code ".($?>>8)) if $?;
 229
 230     print STDERR "done!\n" if $Config{verbose};
 231 }
 232
 233 sub usage {
 234     print STDERR <<".";
 235 usage: $0 --inline src/perl6/Prelude.pm [options]
 236        $0 --precompile src/perl6/Prelude.pm --pugs ./pugs.exe [options]
 237
 238 Creates a Prelude.hs fallback or a Prelude.pm.bin file (written to stdout),
 239 to be loaded by Run.hs.
 240
 241 When pugs is built, a fallback Prelude.hs that contains only a quoted
 242 version of the Prelude code is inlined into the executable, to be
 243 "eval"ed when pugs starts.  After the executable is ready, the Standard
 244 Prelude is precompiled and stored in Binary format in a (conjecturally)
 245 well-defined location for latter runs of pugs to pick up and load quickly.
 246
 247 Additional options:
 248     --verbose, -v     print progress to stderr
 249     --touch,   -t     mark Run.hi and Run.o stale, triggering pugs rebuild
 250     --output,  -o     file to write output to (stdout by default)
 251 .
 252 }