OpenGrok

      1 #!/usr/dcs/software/supported/bin/perl -w
      2 # LLVM Web Demo script
      3 #
      4 
      5 use strict;
      6 use CGI;
      7 use POSIX;
      8 use Mail::Send;
      9 
     10 $| = 1;
     11 
     12 my $ROOT = "/tmp/webcompile";
     13 #my $ROOT = "/home/vadve/lattner/webcompile";
     14 
     15 open( STDERR, ">&STDOUT" ) or die "can't redirect stderr to stdout";
     16 
     17 if ( !-d $ROOT ) { mkdir( $ROOT, 0777 ); }
     18 
     19 my $LOGFILE         = "$ROOT/log.txt";
     20 my $FORM_URL        = 'index.cgi';
     21 my $MAILADDR        = 'sabre (at] nondot.org';
     22 my $CONTACT_ADDRESS = 'Questions or comments?  Email the <a href="http://lists.cs.uiuc.edu/mailman/listinfo/llvmdev">LLVMdev mailing list</a>.';
     23 my $LOGO_IMAGE_URL  = 'cathead.png';
     24 my $TIMEOUTAMOUNT   = 20;
     25 $ENV{'LD_LIBRARY_PATH'} = '/home/vadve/shared/localtools/fc1/lib/';
     26 
     27 my @PREPENDPATHDIRS =
     28   (  
     29     '/home/vadve/shared/llvm-gcc4.0-2.1/bin/',
     30     '/home/vadve/shared/llvm-2.1/Release/bin');
     31 
     32 my $defaultsrc = "#include <stdio.h>\n#include <stdlib.h>\n\n" .
     33                  "int power(int X) {\n  if (X == 0) return 1;\n" .
     34                  "  return X*power(X-1);\n}\n\n" .
     35                  "int main(int argc, char **argv) {\n" .
     36                  "  printf(\"%d\\n\", power(atoi(argv[0])));\n}\n";
     37 
     38 sub getname {
     39     my ($extension) = @_;
     40     for ( my $count = 0 ; ; $count++ ) {
     41         my $name =
     42           sprintf( "$ROOT/_%d_%d%s", $$, $count, $extension );
     43         if ( !-f $name ) { return $name; }
     44     }
     45 }
     46 
     47 my $c;
     48 
     49 sub barf {
     50     print "<b>", @_, "</b>\n";
     51     print $c->end_html;
     52     system("rm -f $ROOT/locked");
     53     exit 1;
     54 }
     55 
     56 sub writeIntoFile {
     57     my $extension = shift @_;
     58     my $contents  = join "", @_;
     59     my $name      = getname($extension);
     60     local (*FILE);
     61     open( FILE, ">$name" ) or barf("Can't write to $name: $!");
     62     print FILE $contents;
     63     close FILE;
     64     return $name;
     65 }
     66 
     67 sub addlog {
     68     my ( $source, $pid, $result ) = @_;
     69     open( LOG, ">>$LOGFILE" );
     70     my $time       = scalar localtime;
     71     my $remotehost = $ENV{'REMOTE_ADDR'};
     72     print LOG "[$time] [$remotehost]: $pid\n";
     73     print LOG "<<<\n$source\n>>>\nResult is: <<<\n$result\n>>>\n";
     74     close LOG;
     75 }
     76 
     77 sub dumpFile {
     78     my ( $header, $file ) = @_;
     79     my $result;
     80     open( FILE, "$file" ) or barf("Can't read $file: $!");
     81     while (<FILE>) {
     82         $result .= $_;
     83     }
     84     close FILE;
     85     my $UnhilightedResult = $result;
     86     my $HtmlResult        =
     87       "<h3>$header</h3>\n<pre>\n" . $c->escapeHTML($result) . "\n</pre>\n";
     88     if (wantarray) {
     89         return ( $UnhilightedResult, $HtmlResult );
     90     }
     91     else {
     92         return $HtmlResult;
     93     }
     94 }
     95 
     96 sub syntaxHighlightLLVM {
     97   my ($input) = @_;
     98   $input =~ s@\b(void|i8|i1|i16|i32|i64|float|double|type|label|opaque)\b@<span class="llvm_type">$1</span>@g;
     99   $input =~ s@\b(add|sub|mul|div|rem|and|or|xor|setne|seteq|setlt|setgt|setle|setge|phi|tail|call|cast|to|shl|shr|vaarg|vanext|ret|br|switch|invoke|unwind|malloc|alloca|free|load|store|getelementptr|begin|end|true|false|declare|global|constant|const|internal|uninitialized|external|implementation|linkonce|weak|appending|null|to|except|not|target|endian|pointersize|big|little|volatile)\b@<span class="llvm_keyword">$1</span>@g;
    100 
    101   # Add links to the FAQ.
    102   $input =~ s@(_ZNSt8ios_base4Init[DC]1Ev)@<a href="../docs/FAQ.html#iosinit">$1</a>@g;
    103   $input =~ s@\bundef\b@<a href="../docs/FAQ.html#undef">undef</a>@g;
    104   return $input;
    105 }
    106 
    107 sub mailto {
    108     my ( $recipient, $body ) = @_;
    109     my $msg =
    110       new Mail::Send( Subject => "LLVM Demo Page Run", To => $recipient );
    111     my $fh = $msg->open();
    112     print $fh $body;
    113     $fh->close();
    114 }
    115 
    116 $c = new CGI;
    117 print $c->header;
    118 
    119 print <<EOF;
    120 <html>
    121 <head>
    122   <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
    123   <title>Try out LLVM in your browser!</title>
    124   <style>
    125     \@import url("syntax.css");
    126     \@import url("http://llvm.org/llvm.css");
    127   </style>
    128 </head>
    129 <body leftmargin="10" marginwidth="10">
    130 
    131 <div class="www_sectiontitle">
    132   Try out LLVM in your browser!
    133 </div>
    134 
    135 <table border=0><tr><td>
    136 <img align=right width=100 height=111 src="$LOGO_IMAGE_URL">
    137 </td><td>
    138 EOF
    139 
    140 if ( -f "$ROOT/locked" ) {
    141   my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$locktime) = 
    142     stat("$ROOT/locked");
    143   my $currtime = time();
    144   if ($locktime + 60 > $currtime) {
    145     print "This page is already in use by someone else at this ";
    146     print "time, try reloading in a second or two.  Meow!</td></tr></table>'\n";
    147     exit 0;
    148   }
    149 }
    150 
    151 system("touch $ROOT/locked");
    152 
    153 print <<END;
    154 Bitter Melon the cat says, paste a C/C++ program in the text box or upload
    155 one from your computer, and you can see LLVM compile it, meow!!
    156 </td></tr></table><p>
    157 END
    158 
    159 print $c->start_multipart_form( 'POST', $FORM_URL );
    160 
    161 my $source = $c->param('source');
    162 
    163 
    164 # Start the user out with something valid if no code.
    165 $source = $defaultsrc if (!defined($source));
    166 
    167 print '<table border="0"><tr><td>';
    168 
    169 print "Type your source code in below: (<a href='DemoInfo.html#hints'>hints and 
    170 advice</a>)<br>\n";
    171 
    172 print $c->textarea(
    173     -name    => "source",
    174     -rows    => 16,
    175     -columns => 60,
    176     -default => $source
    177 ), "<br>";
    178 
    179 print "Or upload a file: ";
    180 print $c->filefield( -name => 'uploaded_file', -default => '' );
    181 
    182 print "<p />\n";
    183 
    184 
    185 print '<p></td><td valign=top>';
    186 
    187 print "<center><h3>General Options</h3></center>";
    188 
    189 print "Source language: ",
    190   $c->radio_group(
    191     -name    => 'language',
    192     -values  => [ 'C', 'C++' ],
    193     -default => 'C'
    194   ), "<p>";
    195 
    196 print $c->checkbox(
    197     -name  => 'linkopt',
    198     -label => 'Run link-time optimizer',
    199     -checked => 'checked'
    200   ),' <a href="DemoInfo.html#lto">?</a><br>';
    201 
    202 print $c->checkbox(
    203     -name  => 'showstats',
    204     -label => 'Show detailed pass statistics'
    205   ), ' <a href="DemoInfo.html#stats">?</a><br>';
    206 
    207 print $c->checkbox(
    208     -name  => 'cxxdemangle',
    209     -label => 'Demangle C++ names'
    210   ),' <a href="DemoInfo.html#demangle">?</a><p>';
    211 
    212 
    213 print "<center><h3>Output Options</h3></center>";
    214 
    215 print $c->checkbox(
    216     -name => 'showbcanalysis',
    217     -label => 'Show detailed bytecode analysis'
    218   ),' <a href="DemoInfo.html#bcanalyzer">?</a><br>';
    219 
    220 print $c->checkbox(
    221     -name => 'showllvm2cpp',
    222     -label => 'Show LLVM C++ API code'
    223   ), ' <a href="DemoInfo.html#llvm2cpp">?</a>';
    224 
    225 print "</td></tr></table>";
    226 
    227 print "<center>", $c->submit(-value=> 'Compile Source Code'), 
    228       "</center>\n", $c->endform;
    229 
    230 print "\n<p>If you have questions about the LLVM code generated by the
    231 front-end, please check the <a href='/docs/FAQ.html#cfe_code'>FAQ</a> and
    232 the demo page <a href='DemoInfo.html#hints'>hints section</a>.
    233 </p>\n";
    234 
    235 $ENV{'PATH'} = ( join ( ':', @PREPENDPATHDIRS ) ) . ":" . $ENV{'PATH'};
    236 
    237 sub sanitychecktools {
    238     my $sanitycheckfail = '';
    239 
    240     # insert tool-specific sanity checks here
    241     $sanitycheckfail .= ' llvm-dis'
    242       if `llvm-dis --help 2>&1` !~ /ll disassembler/;
    243 
    244     $sanitycheckfail .= ' llvm-gcc'
    245       if ( `llvm-gcc --version 2>&1` !~ /Free Software Foundation/ );
    246 
    247     $sanitycheckfail .= ' llvm-ld'
    248       if `llvm-ld --help 2>&1` !~ /llvm linker/;
    249 
    250     $sanitycheckfail .= ' llvm-bcanalyzer'
    251       if `llvm-bcanalyzer --help 2>&1` !~ /bcanalyzer/;
    252 
    253     barf(
    254 "<br/>The demo page is currently unavailable. [tools: ($sanitycheckfail ) failed sanity check]"
    255       )
    256       if $sanitycheckfail;
    257 }
    258 
    259 sanitychecktools();
    260 
    261 sub try_run {
    262     my ( $program, $commandline, $outputFile ) = @_;
    263     my $retcode = 0;
    264 
    265     eval {
    266         local $SIG{ALRM} = sub { die "timeout"; };
    267         alarm $TIMEOUTAMOUNT;
    268         $retcode = system($commandline);
    269         alarm 0;
    270     };
    271     if ( $@ and $@ =~ /timeout/ ) { 
    272       barf("Program $program took too long, compile time limited for the web script, sorry!.\n"); 
    273     }
    274     if ( -s $outputFile ) {
    275         print scalar dumpFile( "Output from $program", $outputFile );
    276     }
    277     #print "<p>Finished dumping command output.</p>\n";
    278     if ( WIFEXITED($retcode) && WEXITSTATUS($retcode) != 0 ) {
    279         barf(
    280 "$program exited with an error. Please correct source and resubmit.<p>\n" .
    281 "Please note that this form only allows fully formed and correct source" .
    282 " files.  It will not compile fragments of code.<p>"
    283         );
    284     }
    285     if ( WIFSIGNALED($retcode) != 0 ) {
    286         my $sig = WTERMSIG($retcode);
    287         barf(
    288             "Ouch, $program caught signal $sig. Sorry, better luck next time!\n"
    289         );
    290     }
    291 }
    292 
    293 my %suffixes = (
    294     'Java'             => '.java',
    295     'JO99'             => '.jo9',
    296     'C'                => '.c',
    297     'C++'              => '.cc',
    298     'Stacker'          => '.st',
    299     'preprocessed C'   => '.i',
    300     'preprocessed C++' => '.ii'
    301 );
    302 my %languages = (
    303     '.jo9'  => 'JO99',
    304     '.java' => 'Java',
    305     '.c'    => 'C',
    306     '.i'    => 'preprocessed C',
    307     '.ii'   => 'preprocessed C++',
    308     '.cc'   => 'C++',
    309     '.cpp'  => 'C++',
    310     '.st'   => 'Stacker'
    311 );
    312 
    313 my $uploaded_file_name = $c->param('uploaded_file');
    314 if ($uploaded_file_name) {
    315     if ($source) {
    316         barf(
    317 "You must choose between uploading a file and typing code in. You can't do both at the same time."
    318         );
    319     }
    320     $uploaded_file_name =~ s/^.*(\.[A-Za-z]+)$/$1/;
    321     my $language = $languages{$uploaded_file_name};
    322     $c->param( 'language', $language );
    323 
    324     print "<p>Processing uploaded file. It looks like $language.</p>\n";
    325     my $fh = $c->upload('uploaded_file');
    326     if ( !$fh ) {
    327         barf( "Error uploading file: " . $c->cgi_error );
    328     }
    329     while (<$fh>) {
    330         $source .= $_;
    331     }
    332     close $fh;
    333 }
    334 
    335 if ($c->param('source')) {
    336     print $c->hr;
    337     my $extension = $suffixes{ $c->param('language') };
    338     barf "Unknown language; can't compile\n" unless $extension;
    339 
    340     # Add a newline to the source here to avoid a warning from gcc.
    341     $source .= "\n";
    342 
    343     # Avoid security hole due to #including bad stuff.
    344     $source =~
    345 s@(\n)?#include.*[<"](.*\.\..*)[">].*\n@$1#error "invalid #include file $2 detected"\n@g;
    346 
    347     my $inputFile = writeIntoFile( $extension, $source );
    348     my $pid       = $$;
    349 
    350     my $bytecodeFile = getname(".bc");
    351     my $outputFile   = getname(".llvm-gcc.out");
    352     my $timerFile    = getname(".llvm-gcc.time");
    353 
    354     my $stats = '';
    355     if ( $extension eq ".st" ) {
    356       $stats = "-stats -time-passes "
    357 	if ( $c->param('showstats') );
    358       try_run( "llvm Stacker front-end (stkrc)",
    359         "stkrc $stats -o $bytecodeFile $inputFile > $outputFile 2>&1",
    360         $outputFile );
    361     } else {
    362       #$stats = "-Wa,--stats,--time-passes,--info-output-file=$timerFile"
    363       $stats = "-ftime-report"
    364 	if ( $c->param('showstats') );
    365       try_run( "llvm C/C++ front-end (llvm-gcc)",
    366 	"llvm-gcc -emit-llvm -W -Wall -O2 $stats -o $bytecodeFile -c $inputFile > $outputFile 2>&1",
    367         $outputFile );
    368     }
    369 
    370     if ( $c->param('showstats') && -s $timerFile ) {
    371         my ( $UnhilightedResult, $HtmlResult ) =
    372           dumpFile( "Statistics for front-end compilation", $timerFile );
    373         print "$HtmlResult\n";
    374     }
    375 
    376     if ( $c->param('linkopt') ) {
    377         my $stats      = '';
    378         my $outputFile = getname(".gccld.out");
    379         my $timerFile  = getname(".gccld.time");
    380         $stats = "--stats --time-passes --info-output-file=$timerFile"
    381           if ( $c->param('showstats') );
    382         my $tmpFile = getname(".bc");
    383         try_run(
    384             "optimizing linker (llvm-ld)",
    385 "llvm-ld $stats -o=$tmpFile $bytecodeFile > $outputFile 2>&1",
    386             $outputFile
    387         );
    388         system("mv $tmpFile.bc $bytecodeFile");
    389         system("rm $tmpFile");
    390 
    391         if ( $c->param('showstats') && -s $timerFile ) {
    392             my ( $UnhilightedResult, $HtmlResult ) =
    393               dumpFile( "Statistics for optimizing linker", $timerFile );
    394             print "$HtmlResult\n";
    395         }
    396     }
    397 
    398     print " Bytecode size is ", -s $bytecodeFile, " bytes.\n";
    399 
    400     my $disassemblyFile = getname(".ll");
    401     try_run( "llvm-dis",
    402         "llvm-dis -o=$disassemblyFile $bytecodeFile > $outputFile 2>&1",
    403         $outputFile );
    404 
    405     if ( $c->param('cxxdemangle') ) {
    406         print " Demangling disassembler output.\n";
    407         my $tmpFile = getname(".ll");
    408         system("c++filt < $disassemblyFile > $tmpFile 2>&1");
    409         system("mv $tmpFile $disassemblyFile");
    410     }
    411 
    412     my ( $UnhilightedResult, $HtmlResult );
    413     if ( -s $disassemblyFile ) {
    414         ( $UnhilightedResult, $HtmlResult ) =
    415           dumpFile( "Output from LLVM disassembler", $disassemblyFile );
    416         print syntaxHighlightLLVM($HtmlResult);
    417     }
    418     else {
    419         print "<p>Hmm, that's weird, llvm-dis didn't produce any output.</p>\n";
    420     }
    421 
    422     if ( $c->param('showbcanalysis') ) {
    423       my $analFile = getname(".bca");
    424       try_run( "llvm-bcanalyzer", "llvm-bcanalyzer $bytecodeFile > $analFile 2>&1", 
    425         $analFile);
    426     }
    427     if ($c->param('showllvm2cpp') ) {
    428       my $l2cppFile = getname(".l2cpp");
    429       try_run("llvm2cpp","llvm2cpp $bytecodeFile -o $l2cppFile 2>&1",
    430         $l2cppFile);
    431     }
    432 
    433     # Get the source presented by the user to CGI, convert newline sequences to simple \n.
    434     my $actualsrc = $c->param('source');
    435     $actualsrc =~ s/\015\012/\n/go;
    436     # Don't log this or mail it if it is the default code.
    437     if ($actualsrc ne $defaultsrc) {
    438     addlog( $source, $pid, $UnhilightedResult );
    439 
    440     my ( $ip, $host, $lg, $lines );
    441     chomp( $lines = `wc -l < $inputFile` );
    442     $lg = $c->param('language');
    443     $ip = $c->remote_addr();
    444     chomp( $host = `host $ip` ) if $ip;
    445     mailto( $MAILADDR,
    446         "--- Query: ---\nFrom: ($ip) $host\nInput: $lines lines of $lg\n"
    447           . "C++ demangle = "
    448           . ( $c->param('cxxdemangle') ? 1 : 0 )
    449           . ", Link opt = "
    450           . ( $c->param('linkopt') ? 1 : 0 ) . "\n\n"
    451           . ", Show stats = "
    452           . ( $c->param('showstats') ? 1 : 0 ) . "\n\n"
    453           . "--- Source: ---\n$source\n"
    454           . "--- Result: ---\n$UnhilightedResult\n" );
    455     }
    456     unlink( $inputFile, $bytecodeFile, $outputFile, $disassemblyFile );
    457 }
    458 
    459 print $c->hr, "<address>$CONTACT_ADDRESS</address>", $c->end_html;
    460 system("rm $ROOT/locked");
    461 exit 0;
    462