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