clang/www/demo/index.cgi

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