1#!/usr/dcs/software/supported/bin/perl 2# LLVM Web Demo script 3# 4 5use strict; 6use CGI; 7use POSIX; 8use Mail::Send; 9use warnings; 10 11$| = 1; 12 13my $ROOT = "/tmp/webcompile"; 14#my $ROOT = "/home/vadve/lattner/webcompile"; 15 16open( STDERR, ">&STDOUT" ) or die "can't redirect stderr to stdout"; 17 18if ( !-d $ROOT ) { mkdir( $ROOT, 0777 ); } 19 20my $LOGFILE = "$ROOT/log.txt"; 21my $FORM_URL = 'index.cgi'; 22my $MAILADDR = 'sabre@nondot.org'; 23my $CONTACT_ADDRESS = 'Questions or comments? Discuss on the <a href="https://discourse.llvm.org">LLVM forum</a>.'; 24my $LOGO_IMAGE_URL = 'cathead.png'; 25my $TIMEOUTAMOUNT = 20; 26$ENV{'LD_LIBRARY_PATH'} = '/home/vadve/shared/localtools/fc1/lib/'; 27 28my @PREPENDPATHDIRS = 29 ( 30 '/home/vadve/shared/llvm-gcc4.0-2.1/bin/', 31 '/home/vadve/shared/llvm-2.1/Release/bin'); 32 33my $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 39sub 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 48my $c; 49 50sub barf { 51 print "<b>", @_, "</b>\n"; 52 print $c->end_html; 53 system("rm -f $ROOT/locked"); 54 exit 1; 55} 56 57sub 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 68sub 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 78sub 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 97sub 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 108sub 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; 118print $c->header; 119 120print <<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> 139EOF 140 141if ( -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 152system("touch $ROOT/locked"); 153 154print <<END; 155Bitter Melon the cat says, paste a C/C++ program in the text box or upload 156one from your computer, and you can see LLVM compile it, meow!! 157</td></tr></table><p> 158END 159 160print $c->start_multipart_form( 'POST', $FORM_URL ); 161 162my $source = $c->param('source'); 163 164 165# Start the user out with something valid if no code. 166$source = $defaultsrc if (!defined($source)); 167 168print '<table border="0"><tr><td>'; 169 170print "Type your source code in below: (<a href='DemoInfo.html#hints'>hints and 171advice</a>)<br>\n"; 172 173print $c->textarea( 174 -name => "source", 175 -rows => 16, 176 -columns => 60, 177 -default => $source 178), "<br>"; 179 180print "Or upload a file: "; 181print $c->filefield( -name => 'uploaded_file', -default => '' ); 182 183print "<p />\n"; 184 185 186print '<p></td><td valign=top>'; 187 188print "<center><h3>General Options</h3></center>"; 189 190print "Source language: ", 191 $c->radio_group( 192 -name => 'language', 193 -values => [ 'C', 'C++' ], 194 -default => 'C' 195 ), "<p>"; 196 197print $c->checkbox( 198 -name => 'linkopt', 199 -label => 'Run link-time optimizer', 200 -checked => 'checked' 201 ),' <a href="DemoInfo.html#lto">?</a><br>'; 202 203print $c->checkbox( 204 -name => 'showstats', 205 -label => 'Show detailed pass statistics' 206 ), ' <a href="DemoInfo.html#stats">?</a><br>'; 207 208print $c->checkbox( 209 -name => 'cxxdemangle', 210 -label => 'Demangle C++ names' 211 ),' <a href="DemoInfo.html#demangle">?</a><p>'; 212 213 214print "<center><h3>Output Options</h3></center>"; 215 216print $c->checkbox( 217 -name => 'showbcanalysis', 218 -label => 'Show detailed bytecode analysis' 219 ),' <a href="DemoInfo.html#bcanalyzer">?</a><br>'; 220 221print $c->checkbox( 222 -name => 'showllvm2cpp', 223 -label => 'Show LLVM C++ API code' 224 ), ' <a href="DemoInfo.html#llvm2cpp">?</a>'; 225 226print "</td></tr></table>"; 227 228print "<center>", $c->submit(-value=> 'Compile Source Code'), 229 "</center>\n", $c->endform; 230 231print "\n<p>If you have questions about the LLVM code generated by the 232front-end, please check the <a href='/docs/FAQ.html#cfe_code'>FAQ</a> and 233the demo page <a href='DemoInfo.html#hints'>hints section</a>. 234</p>\n"; 235 236$ENV{'PATH'} = ( join ( ':', @PREPENDPATHDIRS ) ) . ":" . $ENV{'PATH'}; 237 238sub 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 260sanitychecktools(); 261 262sub 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 294my %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); 303my %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 314my $uploaded_file_name = $c->param('uploaded_file'); 315if ($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 336if ($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 =~ 346s@(\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 460print $c->hr, "<address>$CONTACT_ADDRESS</address>", $c->end_html; 461system("rm $ROOT/locked"); 462exit 0; 463