| Kevin | d68c8f4 | 2007-10-06 05:15:30 +0000 | [diff] [blame] | 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@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; |