#!/usr/local/bin/perl -w

#
# parallelize_program.perl
#
# Analyzes C program for recursive functions,
# inserts profiling instrumentation code
# and adds threads and helper procedures for parallelization
#
# Stefan U. Haenssgen 04-jul-97
#
#
# 04-jul-97	1st version with inspirations from PSP LOC counter
#		- read_lines to read source code
#		- find_procedures to identify procedure code at top
#		   bracket {} level
#		- find_calls to identify procedure invocations at
#		   non-top bracket level
#		- find_recursives to check transitive hull of
#		   procedure calls and identify recursions
#		   using the unique_sort_names subroutine
# 06-jul-97	More comments, added ToDos
#		If procedure is identified, check if such a procedure
#		 has been "identified" before and overwrite that one,
#		 guessing that the first occurence was just a declaration
#		 and not the procedure code itself
#		Also remember correct ending line in this case
#		Sort procedures for starting line number (find_calls
#		 assumes that subsequent entries have increasing line
#		 numbers!)
#		Also match procedures with pointer (*) before them
#		Don't match calls with substrings of procedure names
#		 in them (e.g. "old_main(" shouldn't match "main(")
# 07-jul-97	Added string recognition and elimination
#		Added single line comment handling (thanks to perlop manpage)
#		 and multi-line handling
#		Added procedure header recognition, also headers
#		 spanning multiple lines. Recognize declarations (no
#		 code after header), too.
#		Also handle comments in function call extraction
#		Also recognize calls in one-lined procedures
#		Preparations for instrumentation
#		Renamed "bracket" -> "brace"
# 09-jul-97	Remember where procedure calls occur in @procwherecalled
#		Map procedure name to index using %procnameindex
#		Instrument main program with instument_main (add includes,
#		 add procedure profile entries etc)
#		Skip to after procedure's header with skip_proc_head
# 		Also accept "!" before procedure calls
#		Add generation of profile init code in main
#		Add generation of profile counters in each recursive procedure
#		Find start of procedure's parameters (in parentheses) using
#		 proc_param_start
#		Sub skip_to_end_of_statement for general use, ditto
#		 skip_to_start_of_startement
#		Examine each place where a recursive procedure is called,
#		 add depth parameter, and if the call is recursive (within
#		 the procedure itself), add a branch_count++ after it
#		Added a hack to initialize the profile within main()'s
#		 declarations
# 10-jul-97	Remember old declarations before overwriting them, so that
#		 we can update them later when we add depth parameters etc
#		proc_param_start takes line number again, not procedure's
#		 name, to enable us to handle declarations, too
#		Send final output (instrumented program) to file if
#		 environment IP_OUT set, else stdout
#		Use pattern match variables:
#		 $x (x=1..0) for corresponding parenthesis,
#		 $MATCH for string that was matched, $PREMATCH and
#		 $POSTMATCH for string parts before/after match
#		Cleaned up code (more spaces/free lines etc)
#		Also remember positions of starting parenthesis of
#		 procedure's parameters for each procedure header and call
#		Use that information to make several searches (e.g.
#		 for procedure header) faster and less error-prone,
#		 since the original header detection makes sure no
#		 comments are involved etc
# 11-jul-97	Debugging (correct incides for old declarations)
#		Made procdecls a associative array indexed by procedure
#		 name, so finding things again later is easier (procs
#		 get sorted in between!)
#		Also recognize returns during the scanning phase
#		 and remember their positions for later instrumentation
#		 in array "returns"
#		Use that information for better recognition of returns
#		 in instrumentation
#		Better handling of closing "}" - append to ";" if that
#		 closes the statement (avoiding "if () {xxx}; else..."
#		 syntax error!), prepend it otherwise
#		Major modification: use "change requests" for modifying
#		 program code, don't modify at once but remember where
#		 what has to be inserted, then sort the requests and
#		 handle them in reverse line order. Should eliminate
#		 the possibility of changes modifying the program so
#		 that later analysis or already known offsets fail!
# 12-jul-97	Added a unified procedure to look for end of current statement
#		 (i.e. next "{", "}", ";") taking comments and strings
#		 into account!
#		Use this procedure skip_to_delimiter to make the
#		 old procedures skip_to_{begin,end}_of_statement and
#		 skip_proc_head simpler and more robust
#		Recognize mutual recursion, i.e., don't classify mutual
#		 recursive calls as "external". Handle special case
#		 where one mutually procedure is just used from the
#		 other one and from nowhere else - don't increase the
#		 depth parameter when calling it; mark them with
#		 $mutualonly[$i]=1. Otherwise, increase depth as usual
#		 (pass own depth + 1)
#		Introduced directcalls[] with calls that procedure
#		 directly makes, in addition to allcalls[] which is
#		 the transitive hull of calls (former calledprocs)
#		Add "branch_count++" before (!) the recursive call,
#		 otherwise it might be inside a "return" and nothing
#		 is incremented.
#		Better return matching, also "{}" OK before/after
#		Use ";}" as closing encapsulation to avoid "return x}" which
#		 seems to annoy gcc
#		Completed handling of mutual recursions
# 14-jul-97	Introduced debug level (0=nothing, 1=infos (default), 2=high,
#		 3=detailed)
#		Prefixed any non-essential output with debug level
#		Added argument handling and arguments:
#		- debug N for debug level N
#		- quiet for debug level 0
#		- verbose for debug level 2
#		- noisy for debug level 3
#		- degree N for profile branching degree initialization N
#		- depth N for profile depth init N
#		Check if given file exists and just one file is given
#		Indent program code when adding code in add_change
#		Added use of "atexit" to instrumentation to assure
#		 profile is printed at program's exit - don't need
#		 instrumentation of main()'s end with ProfilePrint
#		 any more, since exit is called implicitly anyway
#		Skip statement at end of procedure that might still be
#		 there before adding code
#		Also allow "=" before procedure call in pattern
#		[now as parallelize_program.perl]
#		Apply change requests in perform_changes(), reset changes
#		Added code to be inserted for thread definitions etc
#		Recognize "/* NOPARALLEL */" annotation during 1st pass
#		 and attribute it to the procedure's name (%noparallels)
#		Detect and remember procedure's variable declaration
#		 in %variables, reformat it into one comma separated line
#		Add thread initialization and defines to code
#		Add init call to main()
#		For each to-be-parallelized procedure, add declaration
#		 (if there wasn't any) and thread predicates
#		Remember type of procedure when scanning (in %proctypes)
#		 as any text before the procedure's occurence
#		Generate thread call, join and wrapper procedures for
#		 each parallelized procedure, adapt parameters etc
#		Insert this code directly before the procedure, to avoid
#		 missing declaration (insertion at start of code might
#		 be before the procedure's necessary declarations)
#		Use default type if no type given for procedure
#		For void procedures, don't use return values
#		Delete "*" etc before using variable names in code
#		Add all initialization procedures before main not
#		 before the 1st line of main but at the end of the
#		 line before that to avoid interference with code
#		 added to main's declarations!
# 16-jul-97	Decision: Just handle void procedures (see below) for
#		 parallelization!
#		Set all other procedures to "noparallel" and give a
#		 warning message
#		For all direct calls fo procedure from other procedures
#		 that are in its recursive call hull, add thread
#		 generation code to it using "add_thread_generation"
#		Locate the place where to put the join code by
#		 using the "needresults" annotation or a braces-skipping
#		 heuristic
#		Use %hasthreadcode to keep track of procedures already
#		 instrumented with thread init/join code
#		Keep track of lines containing needresults annotations in
#		 array @joinlines, also adding any return statements!
#		Add thread call wrapper to appropriate procedure's calls
#		Add joins to joinlines and before end of procedure
#		Do not indent lines starting with "#"
#		Ignore parenthesis count in skip_to_delimiter
#		Process all changes at once, not first the instrumentation
#		 and then the thread stuff
#		Add priority to changes so we can make sure that
#		 some changes are embedded in others if they want to
#		 change the same location (e.g., instrumentation has
#		 to be outside of thread calls, else the branch_count++
#		 gets put into an #if  and all those things)
#		 -> global variable $changeprio (higher -> first)
# 17-jul-97	Initialize each procedure's threads array in dummy procedure
#		 called in the procedure's initialization
#		Use function names instead of starting line numbers to
#		 name newly introduced variables/defines for that function
#		Removed instrumentation completely, just do the
#		 parallelization (instrument_program.perl as separate prog!)
# 18-jul-97	Added atexit handler for thread number printing
#		Because instrumentation doesn't recognize thread calls
#		 as recursive, add depth parameter etc "manually" to them
#		General debugging (indentation, don't add join code
#		 before statement delimiter but after it, ...)
#		Also recognize mutual-only partners and don't increment
#		 their counters
# 19-jul-97	For procedures in which more than one procedure is called
#		 using threads, add extra newthread_FNAME[] arrays for
#		 each of those procedures and use all of them when joining.
#		 (Use only branch_count, no separate branch count for every
#		 procedure - that leaves some newthreads empty, but they
#		 are ignored anyway when they are empty!)
#		For thread introduction, FNAME means the procedure we're
#		 calling from (caller) and CALLNAME means the called proc.
# 21-jul-97	Corrected usage string (parallelizes!)
# 		Use @recursivecalls to keep track of other recursive
#		 procedures that are called directly by this one
# 25-jul-97	Added option -out as alternative to environment variable
#		Run instrumentation automatically, generate temporary file
#		 for parallel code
#		Added option -noprofile to omit profile generation, just
#		 passed to instrumentation
# 28-jul-97	Filter out typedefs from procedure recognition
# 04-aug-97	Renamed "-debug" to "-detail"
# 27-aug-97	Added support for both KEEP_N and ACTIVE_N: Use different
#		 locations for thread counter decrement depending on strategy
#		Added binary on/off #defines for strategies (USE_KEEP_N etc)
#		Introduced /* NOTHREAD */ annotation for recursive calls
#		 that should not be parallelized, e.g. the last call in
#		 a static division (always 2 or 0 branches -> last branch
#		 needs no thread of its own, just adds overhead)
#		Added @nothreadcalls array and skipping of calls
# 10-nov-97	Avoid use of locking for general strategies where it's
#		 not needed: never/neverever/always (resp. #defines !)
# 13-nov-97	Fixed general predicate defines
# 15-jan-98	Output usage instructions also if unknown option given
#		Removed mutualonly-handling, long gone in instrumentation!
#		Added option "-autonostats" to automatically annotate
#		 all NOPARALLEL-annotated procedures also NOSTATS (i.e.
#		 statistics collections only for parallel procedures)
# 16-jan-98	Mark REAPAR output (profiles etc) with machine-recognizable
#		 begin/end separators: BEGIN/END REAPAR PARINFO/THREADINFO,
#		 also giving procedure parallelization information etc
# 28-jan-98	Removed "handling" of non-void return values in thread
#		 joining, didn't do anything anyway
# 03-mar-98	Remove paths for construction of tmpfile
#
#
# Restrictions:
#
# IF-ELSEs AND FORs HAVE TO BE ENCAPSULATED IN BRACES {}
# else the statement recognition/skipping code is confused by source
# code like "if (a) f(b); else g(c);"
#
# PROCEDURES TO BE PARALLELIZED MUST HAVE TYPE VOID.
# Any return values must be handled as reference parameters (passing
# &a and using *a). This makes it possible to insert thread creation
# code without complex analysis of where-is-value-needed and all..
# not to mention programs like
#
#		for (i=1; i<=n; i++) {
#		    if (...) {
#			a[i] = f(x);
#			do_something_with_a[i];
#		    }
#		}
#
# Much easier to handle is this rewritten form:
#
#		for (i=1; i<=n; i++) {
#		    if (...) {
#			f(&(a[i]),x);
#		    }
#		}
#		for (i=1; i<=n; i++) {
#		    if (a[i] valid) {
#			do_something_with_a[i];
#		    }
#		}
#
# This also avoids complications e.g. with "a = f(x) + f(y) + g(z)" ...
#

# TODO:
#	- handle calls with parameters on different lines, e.g.
#		a = f <NEWLINE> (a,b,c)
#	- handle #defines
#

use English;				# Long internal names (e.g. "$MATCH")

# Global variables:

$bracelevel	= 0;			# Level of {} braces
$procnum	= 0;			# Number of procedure
$linenum	= 0;			# Physical line number
@procname       = ("toplevel");		# List of procedure names
%procnameindex  = ("toplevel",0);	# Their indices (toplevel stays at 0)
@allcalls	= ("main:");		# Procedures this one called
@directcalls	= ("main:");		# Procedures this one called directly
@procstartline  = (1);			# Source line this proc starts in
@procstartpos   = (0);			#  and character pos of starting "("
@procendline    = (1);			# Source line this proc ends in
@procwherecalled= ("toplevel|0,0:");	# Where this proc is called directly
%procdecls	= ();			#  and was declared earlier. Format:
					#  "from_line,pos_in_line-to_line:..."
%noparallels    = ();			# Procedures not to be parallelized
%hasthreadcode  = ();			# True if already has thread init code
%variables	= ();			# Procedure's variable list
%proctypes	= ();			# Proc's type (before name in declar.)
@returns	= ();			# All return statements "line,pos"
$returnnum	= 0;			# How many there were
@joinlines	= ();			# All "needresults" annotations
$joinlinenum	= 0;			# How many there were
@recursives	= ("");			# Recursive procedures
$recursivenum   = 0;
@recursivecalls = ("");			# Direct calls to other recursive procs
@nothreadcalls  = ("");			# Calls not to be parallelized
@source         = ("");			# Whole program code
@requests	= ("");			# Program code insertion requests for
$requestnum	= 0;			#  instrumentation - "line:pos:text"
					#  (text is inserted BEFORE pos)
$changeprio     = 3;			# Priority for changes
$debuglevel	= 1;			# Verbosity of output
$initdegree	= 12;			# Default profile initialization degree
$initdepth	= 90;			# Ditto depth

$noprofile	= 0;			# Parallel only (pass to instrument.)

$autonostats	= 0;			# Make NOPARALLEL procs also NOSTATS

$defaulttype    = "int";		# Type for procs with empty type

$outfilename	= "";			# Default = stdout
$tmpfilename	= "";			# Temporary file for parallelized prg.

$instrumentprog = "instrument_program"; # Script that handles instrument.

$instructions = "
usage: $0 [options] filename

       Parallelizes recursive ANSI C source with thread calls.

       Options:
       -detail N    Output detail level. 0=none, 1=informative (default),
                    2=verbose, 3=very detailed, 4=chatterbox
       -degree N    Set max. profile branching degree to N (default = $initdegree)
       -depth N     Set max. profile recursion depth to N (default = $initdepth)
       -autonostats Automatically annotate NOPARALLEL procedures NOSTATS
       -noprofile   Only generate additional parameters but no profile
       -noisy       Same as -detail 3
       -out F       Write parallel program to file F (default = stdout)
       -quiet       Same as -detail 0
       -verbose     Same as -detail 2

";

# Debugging output - print text if level >= debug level
#
sub dprint {
    my $level = shift;
    my $text  = shift;

    if ($level <= $debuglevel) {
	print $text;
    }
}


# Handle parameters - parse command line for arguments, give usage
# information when none found, check if given file exists etc.
#
sub handle_arguments {

    if (!defined($ARGV[0])) {
	die $instructions;	
    }
    
    if (defined($ENV{"PP_OUT"})) {	# Handle environment
        $outfilename = $ENV{"PP_OUT"};
    }
 
    while ($ARGV[0] =~ /^-(\S+)/) {
	$arg = $1;
	shift @ARGV;

	if (($arg eq "out")	 	# Arguments that need string parameter
	   ) {
	    my $x;
	    
	    if (!defined($ARGV[0])) {
		die "ERROR, '-$arg' needs string parameter\n";
	    }
	    $x = $ARGV[0];
	    shift @ARGV;
	    
	    if ($arg eq "out") {
		$outfilename = $x;	# Set output file
	    }
	    
	} elsif (($arg eq "detail")  ||	# Arguments that need integer parameter
	         ($arg eq "degree") ||
	         ($arg eq "depth")
	   ) {
	    my $x;
	    
	    if ( (!defined($ARGV[0])) || (!($ARGV[0] =~ /^[0-9]+$/)) ) {
		die "ERROR, '-$arg' needs integer parameter\n";
	    }
	    $x = $ARGV[0];
	    shift @ARGV;
	    
	    if ($arg eq "detail") {
		$debuglevel = int($x);		# Set debug level
		if (($x < 0) || ($x > 4)) {
		    die "ERROR, output detail level must be between 0 and 4\n";
		}
	    } elsif ($arg eq "degree") {
		$initdegree = int($x);		# Set profile degree
		if ($x < 1) {
		    die "ERROR, profile degree must be > 0\n";
		}
	    } elsif ($arg eq "depth") {
		$initdepth = int($x);		# Set profile depth
		if ($x < 1) {
		    die "ERROR, profile depth must be > 0\n";
		}
	    }

	} elsif ($arg eq "quiet") {
	    $debuglevel = 0;
	} elsif ($arg eq "verbose") {
	    $debuglevel = 2;
	} elsif ($arg eq "noisy") {
	    $debuglevel = 3;
	} elsif ($arg eq "noprofile") {
	    $noprofile = 1;
	} elsif ($arg eq "autonostats") {
	    $autonostats = 1;
	} else {
	    die $instructions;
	}
    }

    if ($#ARGV >= 1) {
        die "ERROR, only one file can be processed at a time!\n";
    }
    
    if (!stat($ARGV[0])) {
	die "ERROR, cannot open input file '$ARGV[0]'\n";
    }

    if ($noprofile == 1) {
	dprint 1,"(Instrumentation of parameters only, no profile addition)\n";
    }

    dprint 2,"detail level = $debuglevel\n";
    dprint 2,"profile degree = $initdegree, depth = $initdepth\n";

    $tmpfilename = "tmp_parallelize_"."$outfilename"."_$$";
    $tmpfilename =~ s/\///g;		# Remove path seps from filename

    dprint 3,"temporary file = $tmpfilename\n";

}


sub read_lines {
    while (<>) {
	chomp;
	$linenum++;
	$source[$linenum] = $_;
	dprint 4, "$linenum $source[$linenum]\n";
    }
}

sub find_procedures {

    my $n = 0;
    my $line = "";
    my $originalline = "";
    my @pline = ("");
    my @pname = ("");
    my @bopens = ("");
    my @bcloses = ("");			# Opening/closing braces in line
    my $oldbracelevel = $bracelevel;
    my $thisprocnum = $procnum;		# For $procendline[x] - x may be !=
    					#  $procnum if it redefines something
    my @tmpprocs = ("");
    my @tmpjoins = ("");
    
    my $cs = 0;				# Position of comment start in line
    my $ce = 0;				# ditto comment's end
    my $inside_comment = 0;		# True if inside comment/quotes
    my $inside_procedure = 0;		# True if inside procedure
    my $inside_header = 0;		# True if inside procedure header
    
    my $pc = 0;				# Parentheis/brace count for header
    my $bc = 0;
    my $maxbc = 0;			# Maximum brace count reached
    my $thisnoparallel = 0;		# No-parallelization annotation seen?
    my $thisvars = "";			# Procedure's variables
    my $thistype = "";			# Procedure's type (all before name :)

    
    while ($n < $linenum) {
	$n++;
	$line = $source[$n];
	$originalline = $line;

	$line =~ s/\"[^\"]*\"//g;	# Remove quotes (ASSUMES that
					#  quotes don't span lines)
	
        # Check if the "/* NOPARALLEL */" annotation can be found.
        # Remember that for the procedure
        #
	if ($line =~ /\/\*[\s]*NOPARALLEL[\s]*\*\//) {
	    
	    $thisnoparallel = 1;
	}

        # Check if the "/* NEEDRESULTS */" annotation can be found.
        # Remember that line and the position in the array @joinlines
        #
	if ($line =~ /\/\*[\s]*NEEDRESULTS[\s]*\*\//) {
	    
	    $joinlinenum++;
	    $joinlines[$joinlinenum] = $n.",".length($PREMATCH);
	    
	    dprint 2,"      -> NEEDRESULTS annotation at line $n,".
		     length($PREMATCH)."\n";
	}

	# Remove comments to avoid interference with analysis
	#
        $line =~ s {
                     /\*     (?# Match the opening delimiter.)
                     .*?     (?# Match a minimal number of characters.)
                     \*/     (?# Match the closing delimiter.)
                   } []gsx;		# Remove inline comments (see perlop :)

	$cs = index($line, "/*");	# Catch multi-line comments
	$ce = index($line, "*/");

        if ($ce >= 0) {	
	    $line =~ s/^.*\*\///g;	# Remove anything before end of comment
	    $inside_comment = 0;	# Now no longer inside comment
	}
        if ($cs >= 0) {	
	    $line =~ s/\/\*.*$//g;	# Remove anything past start of comment
	    $inside_comment = 1;	# Now inside multi-line comment
	}

        if ($inside_comment == 0) {	# Ignore anything inside comments

        # Remember old brace level and compute new one from
        # difference of opening and closing braces
        # ("x" used to ensure that "} abc" yields TWO blocks, not
        # just one because the brace is at the beginning of the line)
        #
        $oldbracelevel = $bracelevel;	# Remember Br.Level before this line
        @bopens  = split( /\{/ , "x".$line."x");
        @bcloses = split( /\}/ , "x".$line."x");
        $bracelevel = $bracelevel + $#bopens - $#bcloses;

        # brace level should also take multiple statements into account,
        # e.g.
        #       x = y(); { etc pp
	#
	# !!! DOES IT ???

        dprint 2,"$n [$oldbracelevel] $originalline\n";

	# Recognize return statements for later use
	# !!! DOES NOT RECOGNIZE TWO RETURNS IN A SINGLE LINE
	#
        if ($line =~ /([\;\}\{\s]+|^)return([^a-zA-Z_0-9]+|$)/ ) {
	    
	    my $mat  = $MATCH;		# Pre/post/match for patterns
	    my $pre  = $PREMATCH;
	    my $post = $POSTMATCH;
	    $mat =~ /return/;

	    # Remember position of return in line (the "r" character's one)
	    #
	    my $pos = length($pre.$PREMATCH);

	    $returnnum++;
	    $returns[$returnnum] = $n.",".$pos;
	    
	    dprint 2,"      -> RETURN at line $n,$pos\n";
	    
	}
	    
        #
        # Look for procedure headers... pattern is:
        #
        #    type1 type2 proc_name(atype1 arg1, atype2 arg2)
        #
        # Types can contain "*()&", names only whitespace.
        # Procedure code must be at top brace level (0)
        #
        # !!! TODO: more stable recognition, also {} () etc check
        #
        if ($oldbracelevel == 0) {

	  # Not yet inside a procedure? Check if we find something
	  # that looks like a proecdure head
	  # While we're at it, remember procedure's variables (all inside
	  # parenthesis) and type (all before procedure's name)...
	  #
          if ($inside_procedure == 0) {
	      
            if ( $line =~ /^([\(\)\&\*\s]*[a-zA-Z][a-zA-Z_0-9]*[\(\)\&\*\s]+)*[a-zA-Z][a-zA-Z_0-9]*[\s]*\(/ ){

                my $isnew = 1;                  # 1 if proc. not already known
                my $thisname = "";
                my $j = 0;
	        my $mat  = $MATCH;		# Pre/post/match for patterns
	        my $pre  = $PREMATCH;
	        my $post = $POSTMATCH;
		my $pos = length($pre.$mat)-1;	# Position of parenthesis
						#  that starts the proc.header
		$thisvars = "";			# Reset potential variables
		$thistype = $MATCH;		# Remember type (w/o proc.name)
		$thistype =~ s/[a-zA-Z][a-zA-Z_0-9]*[\s]*\($//;
		$thistype =~ s/^[\s]*//;
		$thistype =~ s/[\s]*$//;	# Cut off whitespace

		dprint 3,"PRE:MATCH:POST[pos]=$pre:$mat:$post\[$pos\]\n";

                @pline = split(/\(/,
			       $mat." ");	# Extract procedure's name
                @pname = split(/\s/,		#  as last "word" before last
			    $pline[$#pline-1]);	#  opening parenthesis "("
                $thisname = $pname[$#pname];    
                $thisname =~ s/\*//g;           # Remove "*" for ptr. proc's

		# Avoid "recognition" of lines like "typedef void (*proc)();"
		#
		if ($thistype =~ /[\s]*typedef([^a-zA-Z_0-9]+|$)/) {
		    dprint 3,"(Just a typedef, ignoring it)\n";
		} else {
			
                # Check if procedure is already known. If yes, assume
                # that the latest occurence is the real procedure and
                # anything before was a forward declaration.
		# Remember the forward declaration's lines for later
		# (adding new parameters etc)
                #
                for ($j=1; $j <= $procnum; $j++) {
                    if ($thisname eq $procname[$j]) {
			
                        dprint 2,"       -> REDEFINES $thisname".
                              " at lines $procstartline[$j],".
		  	      "$procstartpos[$j] ".
                              " to $procendline[$j]\n";
                        $isnew = 0;
			#
			# Remember old declaration(s)
			#
                        $procdecls{$procname[$j]} = $procstartline[$j].",".
			                       $procstartpos[$j]."-".
			                       $procendline[$j].":";
			#
			# Redefine procedure $j
			#
                        $procname[$j] = $thisname;
                        $procstartline[$j] = $n;
			$procstartpos[$j] = $pos;
                        $procendline[$j] = $n;
                        $thisprocnum = $j;
                    }
                }

                # If procedure is really new, initialize its information
                #
                if ($isnew == 1) {
		    
                    $procnum++;
                    $procname[$procnum] = $thisname;
                    $directcalls[$procnum] = "";    # No calls found inside yet
                    $nothreadcalls[$procnum] = "";  # No no-thread annotat. yet
		    $procwherecalled[$procnum] = "";# Neither calls to it
                    $procdecls{$thisname} = "";	    # No other declarations yet
                    $procstartline[$procnum] = $n;
		    $procstartpos[$procnum] = $pos;
                    $procendline[$procnum] = $n;
                    dprint 2,"      -> START $thistype $procname[$procnum]\n";
                    $thisprocnum = $procnum;
		    $noparallels{$thisname} = 0;    # No NOPARALLEL annot.found
		    $variables{$thisname} = "";	    # Remember proc's variables
		    $hasthreadcode{$thisname} = 0;  # No thread code added yet
		    
		    if ($thistype eq "") {
			dprint 2,"      WARNING - empty type set to ".
			         "$defaulttype\n";
			$thistype = $defaulttype;   # Avoid empty types
		    }
		    $proctypes{$thisname} = $thistype; # Remember type
                }

		# Now we've found a procedure and are inside its header
		#
                $inside_procedure = 1;
		$inside_header = 1;

		# Cut all before and including procedure's name
		# for further analysis (esp. for header information)
		# i.e. take the part after the proedure-detection-match!
		#
		$line = "(".$post;	# "(" was still in match, re-supply it
		$pc = 0;			
		$maxbc = 0;
		$bc = 0;
	    }
            }
	    
          } elsif ($inside_header == 0) {

	      # Complain if inside procedure (outside of header!) and
	      # old brace level still is zero!
	      #
              print "SHOULD NOT HAPPEN: OLD BRACE LEVEL = 0".
		    " AND INSIDE PROCEDURE\n";
	      
          }
        }

	# Examine header: Header ends if
	# - first "{" encountered at top-parenthesis-level "()",
	#    we have a normal procedure then
	# - first ";" encountered at that level, then we just have
	#    a declaration with no code
	#
	if ($inside_header == 1) {
	    
	    @pline = split(//, $line);
	    for ($j=0; $j <= $#pline; $j++) {
		
		if      ($pline[$j] eq "(") {
		    $pc++;
		} elsif ($pline[$j] eq ")") {
		    $pc--;
		} elsif ($pline[$j] eq "{") {
		    $bc++;
		    $maxbc=$bc;
		    if ($pc == 0) {
			$inside_header=0;
		    }
		} elsif ($pline[$j] eq "}") {
		    $bc--;
		}
		
                # Semicolon after header ends procedure (i.e.
                # it was only a procedure declaration)
                #
    		  elsif ($pline[$j] eq ";"){
                     if (($pc == 0) && ($bc == 0)) {
			 
			$inside_header=0;
			$procendline[$thisprocnum] = $n;
			dprint 2,"      -> END   $procname[$thisprocnum]\n";
			if ($maxbc == 0) {
			    dprint 2,"         (was only a declaration)\n";
			}
			$inside_procedure = 0;
			if ($thisnoparallel == 1) {
			    dprint 2,"         (annoted NOPARALLEL)\n";
			    $noparallels{$procname[$thisprocnum]} = 1;
			}
	    		$thisnoparallel = 0;	# Reset annotation recognition
		    }
                }
		if ($inside_header == 0) {
		    $j = $#pline;		# Abort analysis if end of hdr
		} else {
		    $thisvars = $thisvars.$pline[$j];
		}
	    }
	}

	# Procedure ends if we were inside a procedure and the current
	# brace level reaches zero
	#
        if (($inside_header == 0) &&
            ($inside_procedure == 1) &&
	    ($bracelevel == 0)) {
	    
            $procendline[$thisprocnum] = $n;    # Remember procedure's end
            dprint 2,"      -> END   $procname[$thisprocnum]\n";
            $inside_procedure = 0;
	    if ($thisnoparallel == 1) {
		dprint 2,"         (annoted NOPARALLEL)\n";
		$noparallels{$procname[$thisprocnum]} = 1;
	    }

	    # Remove training ")" from procedure's variables
	    # and save them in %variables
	    #
	    $thisvars =~ s/[\s]*\)[\s]*$//g;	# No trailing ")"
	    $thisvars =~ s/^[\s]*\([\s]*//g;	# No leading "("
	    $thisvars =~ s/[\s]*\,[\s]*/\,/g;	# No whitespace around ","
	    
	    $variables{$procname[$thisprocnum]} = $thisvars;
	    dprint 2,"         VARs  $thisvars\n";
	    $thisnoparallel = 0;		# Reset annotation recognition
	    $thisvars = "";
        }

      } else {# inside comment - output comment's text anyway
		  
        dprint 2,"$n [$oldbracelevel] $originalline\n";
	
      }
    }

    # OK, now we have found all procedures...
    #
    # Sort the resulting procedure information according to their
    # starting line number (necessary for find_calls later)
    # [Trick: Use lexical sorting but expand start line number with zeroes]
    #
    for ($j=0; $j<=$procnum; $j++) {
	
	$tmpprocs[$j] = sprintf("%010d", $procstartline[$j]).":".
	                $procstartpos[$j].":".
	                $procendline[$j].":".
			$procname[$j];
    }

    @tmpprocs = sort { $a cmp $b }  @tmpprocs;	      # Do the sort
    for ($j=0; $j<=$procnum; $j++) {
	
	($procstartline[$j], $procstartpos[$j],
	 $procendline[$j], $procname[$j] ) =
	    split(/:/, $tmpprocs[$j]);
	$procnameindex{$procname[$j]} = $j;
	$procstartline[$j] = int($procstartline[$j]); # Remove leading 0s again
	$procstartpos[$j] = int($procstartpos[$j]);
	$procendline[$j] = int($procendline[$j]);
    }
    dprint 3, "Sorted procedures by starting line number\n";

    # Add all returns to the join lines (i.e. places where we
    # will have to join the threads generated in a procedure)
    # and sort them by line number
    #
    for ($j=1; $j<=$returnnum; $j++) {
	$joinlinenum++;
	$joinlines[$joinlinenum] = $returns[$j];
    }
    dprint 3, "Added returns to join lines\n";
    for ($j=1; $j<=$joinlinenum; $j++) {
	my $n;
	my $l;
	($n, $l) = split(/,/, $joinlines[$j]);
	$tmpjoins[$j] = sprintf("%010d,%d", $n, $l);
    }
    @tmpjoins = sort { $a cmp $b }  @tmpjoins;	      # Do the sort
    for ($j=1; $j<=$joinlinenum; $j++) {
	my $n;
	my $l;
	($n, $l) = split(/,/, $tmpjoins[$j]);
	$joinlines[$j] = int($n).",".int($j);
    }
    dprint 3, "Sorted join lines by line number\n";
			      
}

sub find_calls {

    my $n = 0;
    my $line = "";
    my $originalline = "";
    my @bopens = ("");
    my @bcloses = ("");			# Opening/closing braces in line
    my $oldbracelevel = $bracelevel;
    my $j = 0;
    my $thisprocnum = 0;
    my $thisprocname = $procname[$thisprocnum];
    my $thisprocstartline = $procstartline[$thisprocnum];
    my $thisprocstartpos = $procstartpos[$thisprocnum];
    my $nextprocstart = $procstartline[$thisprocnum+1];
    #
    # !!! THIS ASSUMES THAT WE HAVE AT LEAST 2 PROCS!

    my $cs = 0;				# Position of comment start in line
    my $ce = 0;				# ditto comment's end
    my $inside_comment = 0;		# True if inside comment/quotes
    my $thisnothread = 0;		# True if nothread-annotation found

 
    # !!! OR - GIANT PATTERN THAT MATCHES ALL AND THEN /o[nce] ??
    # !!! MIGHT BE MORE EFFICIENT
    
    while ($n < $linenum) {
	
	$n++;
	$line = $source[$n];
	$originalline = $line;
	
	$line =~ s/\"[^\"]*\"//g;	# Remove quotes (ASSUMES that
					#  quotes don't span lines)

        # Check if the "/* NOTHREAD */" annotation can be found.
        # Remember that for the next call
        #
	if ($line =~ /\/\*[\s]*NOTHREAD[\s]*\*\//) {
	    $thisnothread = 1;
	}
	
        $line =~ s {
                     /\*     (?# Match the opening delimiter.)
                     .*?     (?# Match a minimal number of characters.)
                     \*/     (?# Match the closing delimiter.)
                   } []gsx;		# Remove inline comments (see perlop :)

	$cs = index($line, "/*");	# Catch multi-line comments
	$ce = index($line, "*/");

        if ($ce >= 0) {	
	    $line =~ s/^.*\*\///g;	# Remove anything before end of comment
	    $inside_comment = 0;	# Now no longer inside comment
	}
        if ($cs >= 0) {	
	    $line =~ s/\/\*.*$//g;	# Remove anything past start of comment
	    $inside_comment = 1;	# Now inside multi-line comment
	}

        if ($inside_comment == 0) {	# Ignore anything inside comments

	# Keep track of procedure we're in at the moment
	#
	if ( ($n >= $nextprocstart) ) {
	    
	    $thisprocnum++;
	    $thisprocname = $procname[$thisprocnum];
	    $thisprocstartline = $procstartline[$thisprocnum];
	    $thisprocstartpos = $procstartpos[$thisprocnum];
	    
	    if ($thisprocnum < $procnum) {
		$nextprocstart = $procstartline[$thisprocnum+1];
	    } else {				# If this is the last proc,
		$nextprocstart = $linenum+1;	#  continue until end of source
	    }
	}

	# Remember old brace level and compute new one from
	# difference of opening and closing braces
	# ("x" used to ensure that "} abc" yields TWO blocks, not
	# just one because the brace is at the beginning of the line)
	#
        $oldbracelevel = $bracelevel;	# Remember Br.Level before this line
	@bopens  = split( /\{/ , "x".$line."x");
	@bcloses = split( /\}/ , "x".$line."x");
	$bracelevel = $bracelevel + $#bopens - $#bcloses;

	dprint 2,"$n [$oldbracelevel] $originalline\n";

	$line =~ s/\"[^\"]*\"//g;	# Get rid of quoted strings
	    

	# Look for procedure usages, i.e. known procedure names
	# within another procedure.
	# (Trick: ap/prepend space so the search pattern is easier,
	# no explicit handling of start-of-lines)
	#
	if (($oldbracelevel > 0) ||
	    (($#bopens == $#bcloses) && ($#bopens>0))
	   ) {
	    
	    for ($j=1; $j <= $procnum; $j++) {
		
		my $pn = $procname[$j];
	        my $myline = " ".$line." ";
		my $prepos = 0;
		my $pos = 0;

		# Check for one-liner procedure calls. Remove anything
		# before the procedure's body ("...{") for them, so their
		# own procedure name cannot be falsely taken for a call
		#
		if ($oldbracelevel==0) {
		    $myline =~ s/^.*{//;
		    $myline = " ".$myline; # Guarantee space again
		    $prepos = length($MATCH)-1;
		} else {
		    $prepos = 0;	   # Offset for procedure itself
		}
		    
		my $pattern = "[\\s\\*\\(\\&\\)\\!\\=\\}\\;]+([^\\s]+[\\s]+)*".
		              $pn."[\\s]*\\(";
		if ( $myline =~ /$pattern/ ) {

		    # Remember position of opening parenthesis
		    # of procedure call's parameters
		    #
		    $pos = $prepos + length($PREMATCH) + length($MATCH) - 2;
		    dprint 2,"       -> CALL of $pn by $thisprocname\n";
		    $directcalls[$thisprocnum] =
			               $directcalls[$thisprocnum].
				       $pn.":";
		    #
		    # Remember where this procedure call occured
		    # (list structure: "name1|line1,pos1:name2|line2,pos2:...")
		    #
		    $procwherecalled[$j] = $procwherecalled[$j].
			               $thisprocname."|".$n.",".$pos.":";
		    #
		    # Remember if this call was annotated as
		    # "don't use a thread here" (i.e. nothreadcalls[i]
		    # are all calls occuring in i that are not to be
		    # threadified)
		    #
		    if ($thisnothread) {
			$nothreadcalls[$thisprocnum] =
			    $nothreadcalls[$thisprocnum].$pn."|".$n.":";
			$thisnothread = 0;
		        dprint 2,"          Annotated 'NOTHREAD'\n";
		    }
		}
	    }
	 }
	    
      } else {# inside comment - output code 1:1
		  
        dprint 2,"$n [$oldbracelevel] $originalline\n";
	
      }
    }

}

# Sorts names in string alphabetically, delimited by ":",
# and removes duplicates
#
sub unique_sort_names {
    $_ = shift;
    s/[\:]+/\:/g;
    s/\:$//g;
    s/^\://g;				# Remove leading/trailing/2x ":"
    
    if ($_ eq "") {			# Handle empty input
	return "::";
    }
    
    my @names = split( /:/ , $_);	# Split into array and sort it
    @names = sort(@names);
    my $i=0;
    my $j=0;
    my $l=$#names;
    while ($i < $l) {			# Find duplicates and remove them
	
	if ($names[$i] eq $names[$i+1]) {	# THERE HAS TO BE A BETTER WAY
	    for ($j=$i; $j<$l; $j++) {
		$names[$j] = $names[$j+1];
	    }
	    $names[$l] = "";
	    $l--;
	    $i--;
	}
	$i++;
    }
    
    my $r = ":".join(":", @names).":";	# Supply leading/trailing ":" again
    $r =~ s/[\:]+/\:/g;			# Remove duplicate ":"s
    return($r);
}


sub find_recursives {
    my $changes = 1;
    my $oldallcalls = "";
    my $pattern = "";
    my @procs = ();
    my $i;
    my $j;

    # Sort procedure calls within each proc and remove duplicates
    # to eliminate ambiguity.
    # Initialize transitive hull of calls (allcalls)
    #
    for ($i=1; $i<=$procnum; $i++) {	# Start with 1 ignores toplevel (0)
	$directcalls[$i]=unique_sort_names($directcalls[$i]);
	$allcalls[$i]=$directcalls[$i];
    }

    # Examine each procedure: For each procedure that is called inside it,
    # add the procedures called from THAT procedure etc etc until the
    # transitive hull of calls doesn't change any more
    #
    for ($i=1; $i<=$procnum; $i++) {
	dprint 2,"Examining $procname[$i]...\n";
	
	if ($allcalls[$i] eq "::") {
	    
	    dprint 3,"  No calls at all, skipping this one...\n";
	    
	} else {
	    
	  dprint 3,"  Inital list of calls: $allcalls[$i]\n";
	  $changes = 1;
	  while ($changes) {
	    $changes=0;

	    # For this procedure: check if this procedure's call list
	    # contains any other procedure. If yes, add those procedure's
	    # call list to the one's examined (transitive hull)
	    # until no more changes occur.
	    #
	    for ($j=1; $j<=$procnum; $j++) {
		
		$pattern = ":".$procname[$j].":";
		if ( $allcalls[$i] =~ /$pattern/) {
		    
		    $oldallcalls = $allcalls[$i];
		    $allcalls[$i] = unique_sort_names(
				$allcalls[$i].":".$allcalls[$j]);
		    
		    if ($oldallcalls ne $allcalls[$i]) {
			$changes=1;
		    }
		}
	    }
	  }
        }
	dprint 2,"  Final list of calls:  $allcalls[$i]\n";
    }
    dprint 2,"\n";

    # Now, each procedure that appears in its own all-calls list
    # is recursive, either directly or indirectly
    #
    $recursivenum=0;
    for ($i=1; $i<=$procnum; $i++) {
	$recursivecalls[$i] = "";		# Direct calls to other recurs.
	
	$pattern = ":".$procname[$i].":";
	if ( $allcalls[$i] =~ /$pattern/) {
	    $recursivenum++;
	    $recursives[$recursivenum]=$i;	# Remember index of rec. procs
	}
    }
    
    # Build list of direct calls to other recursive procedures
    # called from this one
    #
    for ($i=1; $i<=$recursivenum; $i++) {
	my $pn_i = $recursives[$i];		# Regular procedure index for i
	my $j;

	for ($j=1; $j<=$recursivenum; $j++) {	# Check vs. all other recurs.
	    my $pn_j = $recursives[$j];
	    my $pattern = ":".$procname[$pn_j].":";
	    
	    if ($directcalls[$pn_i] =~ /$pattern/) {
	        $recursivecalls[$pn_i] = $recursivecalls[$pn_i].":".
		 			 $procname[$pn_j];
	    }

	}
        $recursivecalls[$pn_i] = $recursivecalls[$pn_i].":";	# Add delimiter
	dprint 3,"Recursive calls in $procname[$pn_i] = ".
	         "$recursivecalls[$pn_i]\n";
    }

    # (removed all mutualonly handling)

}


# For a given procedure's name, returns the line and the position-in-line
# of the real start of the procedure (i.e. the "{") (0=1st)
#
# !!! recycled from find_procedures - SHARE CODE WITH THAT SUB?
#
sub skip_proc_head {
    my $thisname         = shift;	# Procedure's name
    my $n                = 0;		# Start line of procedure
    my $l                = 0;		# Position within line
    my $maxbc;				# Max. braces level encountered
    my $c;

    $n = $procstartline[$procnameindex{$thisname}];
    $l = $procstartpos[$procnameindex{$thisname}];

    # Skip forward to end of header (i.e. next "{" or ";")
    #
    ($n, $l, $c, $maxbc) = skip_to_delimiter($n, $l, 1);

    # If header ended at ";" and no braces pairs were found in between,
    # we just have a declaration. Too bad.
    #
    if (($c eq ";") && ($maxbc == 0) ) {
	print "skip_proc_head: ERROR, $thisname has only a declaration!\n";
	$l=0;
	$n=0;
    }
    return($n,$l);
}


# Skip from the current position (line, position) in the direction given
# (+/-1) until end of statement is encountered, i.e.
#	 "{", ";", "}"
# Takes strings and comments into account.
#
# Returns line, position and delimiting character encountered
#
# ?!? WHAT HAPPENS TO "a = f(b)" or "a = (int) f(b)" ?!? -> "(" and ")" ?
# ?!? WHAT ABOUT "if (a) f(b); else f(c)" ?!?		 -> "else" ?
#
# "{", ";" and "}" are sure candidates, however...
#
sub skip_to_delimiter {
    my $n   = shift;			# Line number
    my $l   = shift;			# Position within line
    my $dir = shift;			# Search direction (1 or -1)

    my $j;
    my $pc;				# Parenthesis open/close count
    my $bc;				# Ditto braces
    my $maxbc;				# Max. braces level encountered
    my @pline;
    my $found_delim = 0;		# True if delimiter found
    my $inside_comment = 0;		# guess :)
    my $inside_string = 0;

    if (($dir != -1) && ($dir != 1)) {
	print "ERROR: direction in skip_to_delimiter must be +/-1\n";
	return (0,0,"x",0);
    }
    
    dprint 3,"SKIP_TO_DELIMITER: line $n, pos $l length ".length($source[$n]).
	     " : $source[$n]\n";
    $pc = 0;
    $maxbc = 0;
    $bc = 0;
    $line = $source[$n];
    
    while ($found_delim == 0) {

        $j = $l;
	@pline = split(//, $line);
	while ( ($found_delim == 0) &&
                ( ( ($dir>0) && ($j <= $#pline) ) ||	# Until begin/end
	          ( ($dir<0) && ($j >= 0      ) )	#  of line, as long
		)					#  as delimiter not
	      )   {					#  found

	    dprint 4,"line[$j] = $pline[$j]\n";

	    # Ignore contents of strings and comments
	    #
            if ( ($inside_string == 0) &&
		 ($inside_comment == 0) ) {
	        if      ($pline[$j] eq "(") {
		    $pc++;
		} elsif ($pline[$j] eq ")") {
		    $pc--;
		} elsif ($pline[$j] eq "{") {	# Opening/closing brace and ";"
		    $bc++;			#  surely mean statement's end
		    $maxbc=$bc;
# NOT GOOD FOR a=(f(x)+f(y))!		    if ($pc == 0) {
			$found_delim=1;
#		    }
		} elsif ($pline[$j] eq "}") {
		    $bc--;
# ditto		    if ($pc == 0) {
			$found_delim=1;
#		    }
		} elsif ($pline[$j] eq ";"){
# ditto		    if (($pc == 0) && ($bc == 0)) {
		    if ($bc == 0) {
			$found_delim=1;
		    }
		} elsif ($pline[$j] eq "/"){	# Start of comment? I.e.
		    				#  "/" + "*" in current dir.
		    if ( (($dir>0) && ($j<$#pline) && ($pline[$j+1] eq "*")) ||
			 (($dir<0) && ($j>0      ) && ($pline[$j-1] eq "*")) )
		    {
			$inside_comment = 1;	# Yepp, and skip the "*", too
			$j = $j + $dir;
		    }
		} elsif ($pline[$j] eq "\""){	# Start of string?
		    if ( (($dir>0) && ($j<$#pline) && ($pline[$j+1] eq "'")) ||
			 (($dir<0) && ($j>0      ) && ($pline[$j-1] eq "'")) )
 		    {
		        $inside_string = 0;	# Don't see '"' as string
		    } else {
		        $inside_string = 1;	# Anything else starts string
		    }
		}
	    }
	    # Handle inside of string (
	    #
	    elsif ($inside_string == 1) {
		if ($pline[$j] eq "\""){	# End of string?
		    if ( ($j > 0) && ($pline[$j-1] eq "\\") ) {
		        $inside_string = 1;	# \" -> still inside string
		    } else {
		        $inside_string = 0;	# Else (no \") we're outside
		    }
		}
	    }
	    # Handle inside of comment
	    #
	    elsif ($inside_comment == 1) {
		if ($pline[$j] eq "*"){		# End of comment ?
		    if ( (($dir>0) && ($j<$#pline) && ($pline[$j+1] eq "/")) ||
			 (($dir<0) && ($j>0      ) && ($pline[$j-1] eq "/")) )
		    {
			$inside_comment = 0;	# Yepp, and skip the "/", too
			$j = $j + $dir;
		    }
		}
	    }
            if ($found_delim == 1) {
		$l = $j;		# Remember where statement ended
	    }
	    $j = $j + $dir;		# Continue in that direction
	}
	if ($found_delim == 0) {	# Still inside stmt, examine next line
	    
	    if ( ($n <= 1) || ($n >= $linenum) ) {
		print "WARNING: skip_to_delimiter - ";
		if ($dir > 0) {
		    print "END";	# Start/end of program? Warn and
		} else {		#  return last character there
		    print "START";
		}
		print " of program reached!\n";
		return ($n, $j-$dir, $pline[$j-$dir], $maxbc);
	    }
  	    $n = $n + $dir;
	    $line = $source[$n];	# Check next line, and set position
	    if ($dir > 0) {		#  to start resp. end (depending on
		$l=0;			#  search direction
	    } else {
		$l=length($source[$n])-1;
	    }
	}

    }

    return ($n, $l, $pline[$l], $maxbc);

}


# For a given procedure's name and starting line, returns the line
# and the position-in-line of the opening parenthesis of the procedure's
# parameters (0=1st)
#
#
sub proc_param_start{
    my $thisname         = shift;	# Procedure's name
    my $n                = shift;	# Start line of procedure
    my $l                = 0;		# Position within line
    my $line;
    my $prefix;
    my @pline;

    # Remove all before and including the procedure name from the 1st line
    # (position of first parenthesis after procedure's name
    # taken from $procstartpos, computed when procedure was first found)
    #
    $prefix = $procstartpos[$procnameindex{$thisname}];

    return ($n, $prefix);

    # ??? DO WE NEED THE REMAINING CODE ???

    $line = $source[$n];

    # (We CAN BE sure that nothing changed in the source, since
    # all is handled by change requests that are applied at the end of
    # the instrumentation, so we have no moving targets here :)

    # Examine rest of line for first opening parenthesis
    #
    @pline = split(//, $line);
    for ($j=$prefix; $j <= $#pline; $j++) {
	if ($pline[$j] eq "(") {
	    if ($l == 0) {
		$l = $j+length($prefix);
	    }
	}
    }
    if ($l == 0) {
	print "proc_param_start: ERROR, $thisname has only a declaration!\n";
	$n = 0;
	$l = 0;
    }
    return($n,$l);
}


# Starts at the given position (line, index in line starting with 0)
# and returns the position where that statement ends, possibly several
# lines afterwards, as well as the character that ended the search and
# the maximum brace count encountered:
#	(line, position, char, max_bc)
# Returns (0,0,"x",0) if error occured.
# Looks for matching parenthesis etc. Statement ends if parenthesis
# level = 0 and either ";", "{" or "}" are encountered.
#
sub skip_to_end_of_statement {
    my $n = shift;			# Line number to start from
    my $l = shift;			# Position to start from

    dprint 3,"SKIP_TO_END_OF_STATEMENT: line $n, pos $l, length ".
	     length($source[$n])." -> $source[$n]\n";

    return skip_to_delimiter($n, $l, 1);
    
}


# Starts at the given position (line, index in line starting with 0)
# and returns the position where that statement began, possibly several
# lines afterwards, as well as the character that ended the search and
# the maximum brace count encountered:
#	(line, position, char, max_bc)
# Returns (0,0,"x",0) if error occured.
# Looks for matching parenthesis etc. Statement begins if parenthesis
# level = 0 and either ";", "{" or "}" are encountered.
#
sub skip_to_start_of_statement {
    my $n = shift;			# Line number to start from
    my $l = shift;			# Position to start from

    return skip_to_delimiter($n, $l, -1);
    
}


# Add a change request to the list, i.e. a string to be inserted
# before a given line number and position
# (at end of line, 1 character behind EOL is OK, will be recognized
# by insertion later)
# Also add the current change priority (global variable)
#
sub add_change {
    my $n      = shift;		# Line number
    my $l      = shift;		# Position in line
    my $text   = shift;		# Text to be inserted there
    my $spaces = "\n";		# For indentation
    
    dprint 3,"  ADD_CHANGE: line $n, pos $l, prio $changeprio\n";
    dprint 4,"              $text\n";

    # Retain program's indentation - simple heuristic, just add the
    # same whitespace sequence after newline as the line before had
    #
    if ($n > 1) {
	if ($source[$n] =~ /^[\s]+/) {
	    $spaces = "\n".$MATCH;
	}
    }
    $text =~ s/\n([^\#]|$)/$spaces$+/g;	# Do not indent #defines etc

    $requestnum++;
    $requests[$requestnum] = sprintf("%06d",$n).":".
	                     sprintf("%06d",$l).":".
	                     sprintf("%06d",$changeprio).":".
	                     $text;
}


# Applies the globally collected change requests to the source code.
# Sorts them by descending line/position so that changes applied earlier
# do not interfere with later changes (work from last line of program
# to first). Also ensures that high priority changes occur first;
#
sub perform_changes {
    my $j;
    my $n;
    my $l;
    my $prio;
    my @pline;
    
    dprint 2,"\nPerforming change requests\n";
    
    @requests = sort { $a cmp $b } @requests;

    dprint 4,"\n".join("\n", @requests)."\n\n";
    
    for ($j=$#requests; $j>=1; $j--) {
	my @text;
	my $change;

	($n,$l,$prio,@text) = split(":", $requests[$j]);
	$n = int($n);
	$l = int($l);

	$change = join(":", @text);
	
        dprint 4,"SOURCE ($source[$n]) $source[$n]\n";
        dprint 4,"CHANGE ($n,$l) -> $change\n";

	@pline = split(//, $source[$n]);

	if ($l > $#pline) {
	    $source[$n] = $source[$n].$change;
	} else {
	    $pline[$l] = $change.$pline[$l];
	    $source[$n] = join("", @pline);
	}
	dprint 4,"  ->   $source[$n]\n";
	
    }

    $requestnum = 0;		# Reset requests again
    undef(@requests);
    @requests = ("");
    
}


sub parallelize_program {

    # Largish code fragments for addition to program
    #
    my $par_general_declaration =
"
/* Multiprocessor/Thread stuff */

#include <thread.h>
#include <synch.h>
#include <unistd.h>

extern long sysconf(int name);
int  cpu_num = 0;               /* Number of processors online */

int      numthreads = 0;        /* Number of active threads */
int      numallthreads = 0;     /* Number of threads created at all */
rwlock_t numthreads_rwlock;

/* Start new thread if... predicates (general ones) */

#define THREAD_NUMBER          3                        /* R */
#define NEW_THREAD_P_FIRST_N   (numallthreads < cpu_num*THREAD_NUMBER)
#define NEW_THREAD_P_KEEP_N    (numthreads < cpu_num*THREAD_NUMBER)
#define NEW_THREAD_P_ACTIVE_N  (numthreads < cpu_num*THREAD_NUMBER)
#define NEW_THREAD_P_ALWAYS    (1)
#define NEW_THREAD_P_NEVER     (0)
#define NEW_THREAD_P_NEVEREVER (0)

#define NEW_THREAD_P_NAME_FIRST_N   \"FIRST_N\"
#define NEW_THREAD_P_NAME_KEEP_N    \"KEEP_N\"
#define NEW_THREAD_P_NAME_ACTIVE_N  \"ACTIVE_N\"
#define NEW_THREAD_P_NAME_ALWAYS    \"ALWAYS\"
#define NEW_THREAD_P_NAME_NEVER     \"NEVER\"
#define NEW_THREAD_P_NAME_NEVEREVER \"NEVEREVER (NO THREADSTUFF AT ALL)\"



/* use this for neverever! */

#define THREADS_REALLY_DISABLED 0

/* Combine problem specific and general predicate */

/* Switches for on/off and corresponding definitions: */
/* if general predicate is used, activate r/w lock usage. */
/* choose right thread creation predicate (general/depth/combined) */

#define USE_DEPTH_P   0                                 /* R */
#define USE_GENERAL_P 1                                 /* R */

#define USE_FIRST_N  0					/* R */
#define USE_KEEP_N   0					/* R */
#define USE_ACTIVE_N 1					/* R */
#define USE_ALWAYS   0					/* R */
#define USE_NEVER    0					/* R */
#define USE_DEPTH    0					/* R */

#if USE_GENERAL_P && (USE_FIRST_N || USE_KEEP_N || USE_ACTIVE_N)

#define THREAD_RDLOCK rw_rdlock(&numthreads_rwlock)
#define THREAD_UNLOCK rw_unlock(&numthreads_rwlock)
#define THREAD_WRLOCK rw_wrlock(&numthreads_rwlock)

#else	/* No locking necessary for always/never/neverever */

#define THREAD_RDLOCK ;
#define THREAD_UNLOCK ;
#define THREAD_WRLOCK ;

#endif

#if USE_GENERAL_P

#if USE_FIRST_N
#define NEW_THREAD_P        NEW_THREAD_P_FIRST_N
#define NEW_THREAD_P_NAME   NEW_THREAD_P_NAME_FIRST_N
#define NEW_THREAD_P_NUMBER NEW_THREAD_P_NUMBER_FIRST_N
#elif USE_KEEP_N
#define NEW_THREAD_P        NEW_THREAD_P_KEEP_N
#define NEW_THREAD_P_NAME   NEW_THREAD_P_NAME_KEEP_N
#define NEW_THREAD_P_NUMBER NEW_THREAD_P_NUMBER_KEEP_N
#elif USE_ACTIVE_N
#define NEW_THREAD_P        NEW_THREAD_P_ACTIVE_N
#define NEW_THREAD_P_NAME   NEW_THREAD_P_NAME_ACTIVE_N
#define NEW_THREAD_P_NUMBER NEW_THREAD_P_NUMBER_ACTIVE_N
#elif USE_ALWAYS
#define NEW_THREAD_P        NEW_THREAD_P_ALWAYS
#define NEW_THREAD_P_NAME   NEW_THREAD_P_NAME_ALWAYS
#define NEW_THREAD_P_NUMBER NEW_THREAD_P_NUMBER_ALWAYS
#elif USE_NEVER
#define NEW_THREAD_P        NEW_THREAD_P_NEVER
#define NEW_THREAD_P_NAME   NEW_THREAD_P_NAME_NEVER
#define NEW_THREAD_P_NUMBER NEW_THREAD_P_NUMBER_NEVER
#else
#error \"unknown general predicate - check USE_XXX!\"
#endif

#endif

/* Problem specific: recursion depth until which to create threads	*/
/* (for the procedure name from profile_depth_XXX)			*/

";
    
    my $par_depth_declaration = "
#define DEPTH_NUMBER_#FNAME#        3                       /* R */
#define NEW_THREAD_P_DEPTH_#FNAME#  (profile_depth_#FNAME# < DEPTH_NUMBER_#FNAME#)

#if USE_GENERAL_P && USE_DEPTH_P
#define NEW_THREAD_PREDICATE_#FNAME# (NEW_THREAD_P_DEPTH_#FNAME# && NEW_THREAD_P)
#endif
#if USE_GENERAL_P && !USE_DEPTH_P
#define NEW_THREAD_PREDICATE_#FNAME# NEW_THREAD_P
#endif
#if !USE_GENERAL_P && USE_DEPTH_P
#define NEW_THREAD_PREDICATE_#FNAME# NEW_THREAD_P_DEPTH_#FNAME#
#endif
#if !USE_GENERAL_P && !USE_DEPTH_P
#error \"at least one of USE_GENERAL_P and USE_DEPTH_P must be true!\"
#endif

";	# Replace #LINE# with recursive procedure's line number later

    my $par_general_init_code ="

    printf(\"BEGIN REAPAR PARINFO\\n\");

    /* Thread stuff: get number of processors, initialize
     * number-of-threads counters and mutex protecting them
     */
    atexit(PrintThreadNumberReachedAndInfo);
    cpu_num = (int)sysconf(_SC_NPROCESSORS_ONLN);
        { char *ev;
          if ((ev = (char*)getenv(\"T_CPU_NUM\")) != NULL) {
            if ((atoi(ev) > cpu_num) || (atoi(ev)<1)) {
              printf(\"Error, %d processors requested but just %d available\\n!\",
                     atoi(ev), cpu_num);
              exit(815);
            } else {
              cpu_num = atoi(ev);
            }
          }
        }
    printf(\"%d processor%s online\\n\", cpu_num, cpu_num>1?\"s\":\"\");
#if THREADS_REALLY_DISABLED
    printf(\"threads disabled\\n\");
#else
    thr_setconcurrency((int)cpu_num);
    rwlock_init(&numthreads_rwlock, USYNC_THREAD, NULL);
#endif
    numthreads = 0;
    numallthreads = 0;
    
#if USE_GENERAL_P
    printf(\"strategy general   = %s (N=%d)\\n\", NEW_THREAD_P_NAME,
           THREAD_NUMBER);
#endif
#if USE_DEPTH_P
"; 	# Trailing printf(s) for depths supplied separately

    my $par_thread_call_join = "
/*
 * thread_t Thread_#FNAME#(int profile_depth_#FNAME#, #FARGS#)
 *
 * Wrapper call to execute specific function as a new thread
 * with the given parameters.
 * Returns ID of the thread created, for later joining and
 * retrieving results.
 */
thread_t  Thread_#FNAME#(int profile_depth_#FNAME#, #FARGS#)
{
    thread_t                thread_id = 0;
    ThreadArg_#FNAME# *arg;
    
    arg = (ThreadArg_#FNAME#*)malloc(sizeof(ThreadArg_#FNAME#));
    
#FSETS#
	   
    if ( thr_create(NULL,0,                    /* Stack stuff */
                    ThreadWrapper_#FNAME#,     /* Fn to call */
                    (void*)arg,                /* Argument to Fn */
                    0,                         /* Flags */
                    &thread_id) ) {            /* New thread's ID */
        perror(\"Error creating thread\");
        printf(\"%d threads created so far. Aborting\\n\", numallthreads);
        exit(123);
    }
    return(thread_id);
}
/*
 * #FTYPE# Join_#FNAME#(thread_id)
 *
 * Waits for given thread to finish, unpacks its result from the
 * thread's return value and returns it.
 */
#FTYPE# Join_#FNAME#(thread_t thread_id)
{
    void *result;

    thr_join(thread_id, NULL, &result);

#if USE_KEEP_N
    THREAD_WRLOCK;
    numthreads--;
    THREAD_UNLOCK;
#endif

    return;
}


/*
 * ThreadWrapper_#FNAME#(arg)
 *
 * This function is used at the new thread's start.
 * It unpacks its arguments (ThreadArg struct *) and then calls
 * the specific function with the correct arguments
 */
void *ThreadWrapper_#FNAME#(void *arg)
{

    #FRESULT#
    
    /* Call function, get result */

    #FCALL#
    
    free(arg);

#if !USE_KEEP_N
    THREAD_WRLOCK;
    numthreads--;
    THREAD_UNLOCK;
#endif

    thr_exit((void*)#FRETURN#);
}

";      # Thread call and join wrapper, #FNAME# etc get replaced later "
    
    my $n;
    my $l;
    my $j;
    my $startcode;
    my $ipdepths = "";


    # All the time, use $changeprio to make sure the thread changes get
    # added at the right position relative to the instrumentation changes,
    # i.e. instrumentation encapsulates thread generation/calls.
    # Instrumentation was done with prio 3 (default), so prio 1 means
    # things are added before an instrumentation and 5 means after
    # (textually before/after! A change inserts the string before the
    # given position!)
    #
    
    # Add all the definitions/declarations for thread usage.
    # Also define predicates for each recursive procedure to
    # be parallelized (i.e. no "noparallel" annotation applied).
    # This code goes into $startcode to be inserted at the program's
    # very beginning.
    #
    # Furthermore, add thread code (wrapper, joiner, ...) directly
    # before each procedure, code in $threadcode
    # (Has to be directly before procedure, since e.g. declarations
    # that are used in the procedure's variables and types might be
    # not yet defined if the code is used earlier. Directly before
    # the procedure, however, they have to be OK to use).
    #
    dprint 2,"Adding general thread declaration\n";

    $startcode = $par_general_declaration;
    
    dprint 2,"Adding procedure specific thread declaration\n";

    for ($j=1; $j<=$recursivenum; $j++) {
	my $pn = $recursives[$j];
	my $thisname = $procname[$pn];
	my $thisstartline = $procstartline[$pn];
	my $thisstartpos = $procstartpos[$pn];
	my $threadcode = "";
	my $thisnoparallel = 0;	# 1 if procedure is not to be parallelized

	dprint 2,"  $thisname ...\n";

	# Don't add code for procedures that were annoted as
	# not to be parallelized
	#
	if ($noparallels{$thisname} == 1) {
	    dprint 2,"    (annoted NOPARALLEL, skipping)\n";
	    $thisnoparallel = $autonostats;

	} elsif ($proctypes{$thisname} ne "void") {

	    # !!! We can only handle void procedures, anything else requires
	    # extreme efforts (where are results used, when do we assign
	    # them, to what, how do we map the results to the threads, ...)
	    #
	    print "  WARNING, can only parallelize void procedures, but\n";
	    print "  $thisname has type $proctypes{$thisname}. Skipping it.\n";

	    $noparallels{$thisname} = 1;	# Mark this one "NOPARALLEL" !
	    $thisnoparallel = $autonostats;
	    
	} else {
	    my $t   = $par_depth_declaration;
	    my $v;
            my $w;
	    my $jj;

	    # Generate defines for procedure
	    #
	    $t =~ s/\#LINE\#/$thisstartline/g;
	    $t =~ s/\#FNAME\#/$thisname/g;
	    $startcode = $startcode.$t;
	    
	    # Generate (new) procedure declaration if this procedure
	    # does not already have a forward declaration
	    #
	    if ($procdecls{$thisname} ne "") {
		dprint 3,"    (already has a declaration)\n";
		
	    } else {
		
		# THIS DOES NOT ADD THE DEPTH PARAMETER "MANUALLY"
		# since instrumentation (which takes place AFTER
		# parallelization) finds the procedure declaration
		# and adds it itself. Instrumentation just doesn't
		# find any thread calls/declarations since they are
		# not recursive and are not directly connected to the
		# procedure itself!
		#
		$threadcode = $threadcode.
		     $proctypes{$thisname}." ".
		     $thisname."(".
#		     "int profile_depth_$thisname, ".
	             $variables{$thisname}.
	             ");\n\n";
		
		dprint 3,"    Added declaration: $threadcode";
	    }

	    # Generate struct to hold the procedure's parameter for
	    # passing them to a thread later
	    # Supply Profile Depth "manually" here, too
	    #
	    $t = "typedef struct {\n".
		 "  int profile_depth_$thisname;\n  ".
		 join(";\n  ", split(/,/, $variables{$thisname}) ).
		 ";\n} ThreadArg_".
		 $thisname.
		 ";\n\n";
	    dprint 3,"    Added struct for variables\n";
 	    $threadcode = $threadcode.$t;
	    
	    # Generate forward declaration of thread wrapper function
	    #
	    $t = "void *ThreadWrapper_".
		 $thisname.
		 "(void *arg);\n\n";
	    dprint 3,"    Added wrapper forward declaration\n";
	    $threadcode = $threadcode.$t;

	    # Generate depth print statement for later use in main()
	    #
	    $ipdepths = $ipdepths.
		        "    printf(\"strategy max depth (".
                        $thisname.
                        ") = %d\\n\", DEPTH_NUMBER_".
                        $thisname.
			");\n";

	    # Generate thread call (Thread_xxx) and thread join (Join_xxx)
	    # code by inserting the appropriate variable names, function
	    # names etc etc.
	    #
	    $t = $par_thread_call_join;
	    $t =~ s/\#FNAME\#/$thisname/g;	# Set procedure's name
	    $v = $proctypes{$thisname};
	    $t =~ s/\#FTYPE\#/$v/g;		# Set its type
	    $v = $variables{$thisname};
	    $t =~ s/\#FARGS\#/$v/g;		# Set its arguments

	    # Go through all the procedure's variables - extract them
	    # from the variable's list and get the variable's name
	    # without anything before it (e.g. "int *a" -> "x")
	    #
	    my @vv = split(",", $variables{$thisname});
	    my $ii;				# Set "arg->x = x" init's
	    $v = "    arg-> profile_depth_$thisname ".
		 "= profile_depth_$thisname;\n";#  for wrapping args in struct
            $w = "((ThreadArg_$thisname*) arg)".#  and for calling proc
		 "-> profile_depth_$thisname,\n";# (supply depth parameter)
	    
	    for ($ii=0; $ii<=$#vv; $ii++) {
		
		@vname = split(/[\s\*\(\)\&]+/,	# Var.Name = last "word"
			       $vv[$ii]);	#  (also kills "*" before var!)
		my $vn = $vname[$#vname];
		
		$v = $v."    arg-> $vn = ".
                        "$vn;\n";		# Generate arg $v
                $w = $w."        ((ThreadArg_$thisname*) arg) -> ".
                        "$vn";
                if ($ii < $#vv) {		# Generate call $w
                    $w = $w.",\n";		# (no "," before last argument)
                }
	    }
	    $t =~ s/\#FSETS\#/$v/g;		# Set argument defs
            $w = $thisname."(".$w."    \n);\n";
	    $t =~ s/\#FCALL\#/$w/g;		# Set function call

	    # If recursive function has type "void", return (void*)NULL
	    # and don't declare a result variable for the Wrapper,
	    # else do it correctly
	    #
	    if ($proctypes{$thisname} eq "void") {
		
	        $t =~ s/\#FRESULT\#//g;		# Void, no return value needed
	        $t =~ s/\#FRETURN\#/NULL/g;
	        $t =~ s/\#FCAST\#//g;
		
	    } else {				# Not void, use return value

		# THIS SHOULD NOT HAPPEN, since we only handle void procedures
		# at the moment...
		#
		$v = $proctypes{$thisname}." result;";
	        $t =~ s/\#FRESULT\#/$v/g;
	        $t =~ s/\#FRETURN\#/result/g;
		$v = "(".$proctypes{$thisname}.") result;";
	        $t =~ s/\#FCAST\#/$v/g;
	    }


	    dprint 3,"    Added thread call and join code\n";
	    
	    $threadcode = $threadcode.$t."\n";

	    add_change($thisstartline,0,$threadcode);

	    
	    # Now take all direct calls of this procedure into account
	    # that take place in other recursive procedures, including
	    # itself.
	    #
            for ($jj=1; $jj<=$recursivenum; $jj++) {
	        my $pn_j = $recursives[$jj];	# Regular procedure index for j
		my $thispattern  = ":".$thisname.":"; 
		my $otherpattern = ":".$procname[$pn_j].":"; 

	        # Does procedure $jj call $pn (this one) directly
		# and is called by $pn at least indirectly?
		#
	        if ( ($directcalls[$pn_j] =~ /$thispattern/ ) &&
		     ($allcalls[$pn]      =~ /$otherpattern/) ) {
		    dprint 3,sprintf("%-20s ",$procname[$pn]).
			     " directly called by recursive ".
			     "$procname[$pn_j] ?\n";

		    # Add thread generation code to the calling procedure
		    #
		    dprint 2,"Adding thread generation for calls of ".
		    	     "$thisname by $procname[$pn]\n";
		    add_thread_generation($thisname,
					  $procname[$pn_j]);
		    $changeprio = 3;
		}
	    }
	}

	# If procedure is not to be parallelized and
	# the autonostats option was set, add NOSTATS
	# annotation before it.
	#
	if ($thisnoparallel) {
	    add_change($thisstartline, 0, "/* NOSTATS */\n\n");
	}
    }
    $startcode = $startcode."\n\n";

    # OK, add all that init stuff to begin of program
    #
    add_change(1,0,$startcode);
    

    # Add thread initialization code using dummy variable initialization
    # within main() and insert the corresponding procedure bedore main()
    # as well as the exit handler that prints the number of threads...
    #
    dprint 2,"Adding thread initialization etc to main()\n";
    
    ($n,$l) = skip_proc_head("main");
    add_change($n, $l+1,  "\n  int dummy_thread_init = do_thread_init();\n");
    
    $n = $procstartline[$procnameindex{"main"}]-1;

    $t = "\n".
	 "void PrintThreadNumberReachedAndInfo() {\n".	# Define atexit handler
         "   printf(\"BEGIN REAPAR THREADINFO\\n\");\n".
	 "   printf(\"total number of threads created = %d\\n\",\n".
	 "          numallthreads);\n".
         "   printf(\"END REAPAR THREADINFO\\n\");\n".
         "}\n\n";

    $t = $t."int do_thread_init(){\n".		# Add thread init code
	 $par_general_init_code.
         $ipdepths.				# (previously generated!)
	 "#endif\n\n";

    $t = $t."printf(\"\\n\");\n";
    
    for ($j=1; $j<=$recursivenum; $j++) {	# Add procedure information
						#  for each parallelized proc.
	my $pn  = $recursives[$j];
	my $pns = $procname[$pn];

	if ($noparallels{$pns} == 0) {
	    $t = $t.
	      "  printf(\"Parallel procedure (%2d) %-20s at line %4d\\n\",\n".
	      "         ".$j.", \"".$pns."\", ".$procstartline[$pn].");\n"
        }

    }
    $t = $t."printf(\"END REAPAR PARINFO\\n\");".
            "}\n\n";
    
    # Add all that just at the end of the last line before main
    # (and before instrumentation)
    #
    $changeprio = 1;
    add_change($n, length($source[$n]), $t); # or length +1 ??
    dprint 3,"    Added thread main() code\n";

    
    &perform_changes();		# Apply code insertions and reset requests

}


# For a given called procedure and the procedure calling that one,
# adds thread generation code to the calling procedure around the
# called procedure's invocation.
# Remembers which procedures already received the main initialization
# and doesn't add that code to them twice.
#
sub add_thread_generation {
    my $calledname = shift;		# Procedure called
    my $callednum;			#  and its number
    my $callername = shift;		# Where the call(s) occured
    my $callernum;			#  and that procedure's number
    my $callline = 0;			# Line where current call occured
    my $n;
    my $l;
    my $line;
    my $s;
    my $w;

    # CALLNAME gets replaced by the procedure we're calling (for which
    # threads are generated), FNAME is the procedure we're currently
    # in (which does the call). May be identical, but don't have to be
    # with mutual recursion!
    #
    my $thread_init_code_body = "
    thread_t newthreads_#CALLNAME#[#MAXT#];";
    
    my $thread_init_code_end = "
    int      nt_i = init_threads_#FNAME#(#NTS#);
";

    
    my $thread_init_proc_code_start = "
int init_threads_#FNAME#(#NTSDECL#) {
    int nt_i;
    for (nt_i = 0; nt_i < #MAXT#; nt_i++) {";
	
    my $thread_init_proc_code_body = "
        newthreads_#CALLNAME#[nt_i] = (thread_t) 0;";
    
    my $thread_init_proc_code_end = "
    }
    return 0;
}
";

    # "#if ..." is prepended to this directly later.
    # Use [branch_count-1] because branch_count is incremented BEFORE
    # the procedure's call
    #
    # Add ";" around call text to make recognition of call
    # and correct placement of branch counters easier for the
    # separate instrumentation run later
    #
    # Add branch_count++ explicitly before thread call, since instrumentation
    # doesn't recognize thread call as recursion
    #
    # #PDCALL# = thread call including profile depth
    # (FNAME refers to the procedure we're in here - CALL refers to
    #  the procedure called)
    #
    my $thread_call_wrapper_code = ";
#else
    /* Create new thread if predicate tells us to */
    /* (use rwlock because predicate may read number-of-threads etc) */

    THREAD_RDLOCK;
    if (NEW_THREAD_PREDICATE_#FNAME#) {     /* Condition GO */
        THREAD_UNLOCK;
        THREAD_WRLOCK;                      /* Now serious */
        if (NEW_THREAD_PREDICATE_#FNAME#) { /* Condition still OK? */
            numallthreads++;
            numthreads++;                   /* OK, new thread! */
            THREAD_UNLOCK;
            branch_count++;
            newthreads_#CALLNAME#[branch_count-1] = Thread_#PDCALL#;
        } else {                            /* Someone else created one */
            THREAD_UNLOCK;                  /* so we can't any more */
            #CALL#;
        }
    } else {                                /* Condition not OK, */
        THREAD_UNLOCK;                      /* perform serial call */
        #CALL#;
    }
#endif

";

    # Thread joining - one thread array for each thread called procedure,
    # and one Join call for each of those arrays
    #
    my $thread_join_code_start = "
;
#if THREADS_REALLY_DISABLED
#else
/* If thread was created, join it */
for (nt_i = 0; nt_i < branch_count; nt_i++) {
";
    my $thread_join_code_body = "
    if (newthreads_#CALLNAME#[nt_i]) {
        Join_#CALLNAME#(newthreads_#CALLNAME#[nt_i]);
        newthreads_#CALLNAME#[nt_i] = (thread_t) 0; /* Mark thread as joined */
    }
";  # Gets instanciated for each thread called procedure
    my $thread_join_code_end = "
}
#endif

";

    $callernum = $procnameindex{$callername};
    $callednum = $procnameindex{$calledname};

    dprint 3,"    Adding threads for call of $calledname ($callednum) by ".
  	     "$callername ($callernum) lines $procstartline[$callernum] ".
  	     "to $procendline[$callernum]\n";

    # If procedure doesn't yet have thread initialization code,
    # add it [could have such code if several thread-instrumentable
    # calls for different procedures are inside it]
    # Also add thread join code before each joinline (i.e. a return
    # statement or an needresults annotation) and before the procedure's
    # end
    #
    if ($hasthreadcode{$callername} == 0) {
	$hasthreadcode{$callername} = 1;
	
	my $k;
	my $i;
	my $c;
	my $maxbc;			# For all thread-proce called here:
	my $thread_init_code = "";	# - Thread array initialization
	my $thread_init_proc_code = "";	# - Initialization procedure
	my $thread_join_code = "";	# - Thread join
	my $nts = "";			# newthread_NAME as comma list
	my $ntsdecl = "";		# newthread_NAME as comma list + type

	$ss = $directcalls[$callernum];
	$ss =~ s/^://g;			# Avoid empty split results
	$ss =~ s/:$//g;
        my @directcalledhere = split(/:/, $ss);

	$thread_init_proc_code = $thread_init_proc_code_start;
	$thread_join_code = $thread_join_code_start;
        dprint 3,"Direct calls here = $directcalls[$callernum]\n";
	
	# Prepare thread array etc for each parallely called procedure
	# in this procedure ($callername)
	#
	for ($i=0; $i<=$#directcalledhere; $i++) {
	    my $nm  = $directcalledhere[$i];
	    my $num = $procnameindex{$nm};
	    my $pat = ":".$num.":";
	    
 	    dprint 4,"NM = $nm PAT = $pat  RECS = ".":".
		join(":",@recursives).":\n";
	    
	    # Procedure called here is parallel if it's recursive
	    # and not marked noparallel
	    #
	    if ( ($noparallels{$nm} == 0) &&
		 ((":".join(":",@recursives).":") =~ /$pat/)
	       ) {
		my $ss;

		# Now generate init/procedure/join code and insert
		# called procedure's name in #CALLNAME# - all other
		# substitutions (#FNAME# for caller etc pp) are
		# performed later for the code generated here.
		#
		dprint 3,"    Adding threads/init/join code for parallel ".
		         "call of $nm by $callername\n";

		# Keep track of newthread arrays (for call of init procedure
		# and for that procedure's header)
		#
		$nts = $nts.", &(newthreads_".$nm."[0])";
		$ntsdecl = $ntsdecl.", thread_t *newthreads_".$nm;

		# Build code bodies for init/proc/join
		#
		$ss =  $thread_init_code_body;
		$ss =~ s/\#CALLNAME\#/$nm/g;
		$thread_init_code = $thread_init_code.$ss;
		
		$ss =  $thread_init_proc_code_body;
		$ss =~ s/\#CALLNAME\#/$nm/g;
		$thread_init_proc_code = $thread_init_proc_code.$ss;
		
		$ss =  $thread_join_code_body;
		$ss =~ s/\#CALLNAME\#/$nm/g;
		$thread_join_code = $thread_join_code.$ss;
		
	    }
	    
	}
	# Add code ends to init/proc/join code
	#
	$thread_init_code = $thread_init_code.
	                    $thread_init_code_end;
	$thread_init_proc_code = $thread_init_proc_code.
			    $thread_init_proc_code_end;
	$thread_join_code = $thread_join_code.
			    $thread_join_code_end;
	$nts     =~ s/^\,[\s]*//g;
	$ntsdecl =~ s/^\,[\s]*//g;	# Remove first ", " from lists
	
	dprint 3,"    Adding thread initialization code to $callername\n";

	# Insert thread array for procedure and initialization by call to
	# init_threads_FNAME before procedure's variable declarations
	#
	$s =  $thread_init_code;
	$s =~ s/\#MAXT\#/$initdegree/g;	# Max. # of threads = initdegree
	$s =~ s/\#FNAME\#/$callername/g;# Procedure name
	$s =~ s/\#NTS\#/$nts/g;		# newthread array calls
	
	($n,$l) = skip_proc_head($callername);
        add_change($n, $l+1, $s);	# Add init code to procedure start

	# Insert thread array initialization procedure before procedure
	# itself
	#
	$s = $thread_init_proc_code;
	$s =~ s/\#MAXT\#/$initdegree/g;	# Max. # of threads = initdegree
	$s =~ s/\#FNAME\#/$callername/g;# Procedure name
	$s =~ s/\#NTSDECL\#/$ntsdecl/g;	# newthread array parameters

	$n = $procstartline[$callernum];
        add_change($n, 0, $s);		# Add init proc before procedure
	
        $s =  $thread_join_code;
        $s =~ s/\#FNAME\#/$calledname/g;# Add caller procedure's join
	
	# Add code before each join line within the procedure's
	# line range
	#
	for ($k=1; $k<=$joinlinenum; $k++) {
	    
	    ($n, $l) = split(/,/, $joinlines[$k]);	# Examine join line
	    dprint 4,"join line $n, $l\n";
    	    if (($n >= $procstartline[$callernum]) &&	# Within procedure?
		($n <= $procendline[$callernum]) ) {
		
                dprint 3,"    join: $callername ($callernum) lines ".
		         "$procstartline[$callernum] ".
  	                 "to $procendline[$callernum] - n=$n pos=$l\n";
		
		($n, $l, $c, $maxbc) = skip_to_start_of_statement($n, $l);

                $changeprio = 5;
		add_change($n, $l+1, $s);
		
 		dprint 3,"    Added join code to $callername, line $n\n";
	    }

	}

	$n = $procendline[$callernum];
	
        ($n, $l, $c, $maxbc) = skip_to_end_of_statement($n,0);
        $changeprio = 1;
	add_change($n, 0, $s);
	
	dprint 3,"    Added join code to end of $callername, line $n\n";
	
    } else {
	
	dprint 3,"    $callername already has thread initialization code\n";
    }

    # Add thread generation code to all calls of the procedure
    # inside the caller procedure
    #
    @calls = split(/:/, $procwherecalled[$callednum]);
    for ($j = 0; $j <= $#calls; $j++) {
	($s, $n, $l) = split(/[\|\,]/, $calls[$j]);
    
	if ($s eq $callername) {	# Call in this procedure, go for it
	
	    my $sline = $n;
	    my $spos  = $l;
	    my $eline = $n;
	    my $epos  = $l;
	    my $c;
	    my $maxbc;
	    my @pline;
	    my $pattern;
	    my $subst;
	    my $pdcalltext;		# Call text including depth params
	    my $ntcalls;		# Nothread-annotated calls
	    my $ntpat;
	    
	    dprint 3," Found call of $calledname in $callername at line ".
		     "$n pos $l\n";

	    # Check if this call was annotated as "don't use a thread here"
	    #
	    $ntcalls = ":".$nothreadcalls[$callernum].":";
	    $ntpat = ":".$calledname."\\|".$n.":";	# Careful with "|" !!

	    if ( $ntcalls =~ /$ntpat/) {
		dprint 3," Call annotated 'NOTHREAD', skipping it\n";
		
	    } else {

	    ($sline, $spos, $c, $maxbc) = skip_to_start_of_statement($n,$l);
	    ($eline, $epos, $c, $maxbc) = skip_to_end_of_statement($n,$l);

	    # Now we have the statement containing the call...
	    # remember the exact code in $calltext
	    #
	    $calltext = "";
	    $n = $sline;
	    $l = $spos+1;
	    @pline = split(//, $source[$n]);
	    while ( ($n < $eline) ||			# Go from start pos+1
                    ( ($n == $eline) && ($l < $epos) )	#  to end pos-1
		  ) {					#  (skip delimiters)
		if ($l <= $#pline) {
		    $calltext = $calltext.$pline[$l];
		}
		$l++;
		if ($l > $#pline) {
		    $n++;
   	            @pline = split(//, $source[$n]);
		    $l = 0;
		}
	    }
            $calltext =~ s {
                     /\*     (?# Match the opening delimiter.)
                     .*?     (?# Match a minimal number of characters.)
                     \*/     (?# Match the closing delimiter.)
                   } []gsx;	# Remove inline comments (see perlop :)
	    $calltext =~ s/^[\s]*//g;			# Remove whitespace
	    $calltext =~ s/[\s]*$//g;
	    dprint 3," call text from $sline,$spos to $eline,$epos:\n".
		     "$calltext\n";
	    #
	    # Also supply depth parameter to thread call (which isn't
	    # recognized by instrumentation of course)
	    #
            $pdcalltext =  $calltext;
            $pattern    =  "(".$calledname."[/s]*\\()";
	    $subst  =  $calledname."\(profile_depth_".$callername."\+1\, ";
            $pdcalltext =~ s/$pattern/$subst/g;

	    # Prepend #if-code before call itself
	    # (but after an instrumentation, ergo prio 5)
	    #
            $changeprio = 5;
	    add_change($sline, $spos+1, "\n#if THREADS_REALLY_DISABLED\n;");

	    # Append remaining thread generation after call itself
	    #
            $s =  $thread_call_wrapper_code;
	    $s =~ s/\#CALL\#/$calltext/g;	# Add called procedure's call
	    $s =~ s/\#CALLNAME\#/$calledname/g;	# Correct numthread_CALLNAME
	    $s =~ s/\#PDCALL\#/$pdcalltext/g;	# Supply thread call w. depth
	    $v =  $procstartline[$callernum];
	    $s =~ s/\#LINE\#/$v/g;		# Add caller's start line
	    $s =~ s/\#FNAME\#/$callername/g;	# Add caller's name

            $changeprio = 1;
	    add_change($eline, $epos, $s);
 	  } # nothreadcall annotation
	}
    }
    
}




# Main program


my $j;
	    

&handle_arguments();

dprint 1,"\nReading source code...\n";
dprint 1,"\n";
&read_lines();

dprint 1,"\nIdentifying procedures...\n";
dprint 1,"\n";
&find_procedures();

dprint 1,"\nFound the following procedures:\n\n";
for ($j=1; $j<=$procnum; $j++) {
    my $s;
    $s=sprintf("%3d) procedure %-20s from line %4d to %4d\n",
	      $j, $procname[$j], $procstartline[$j], $procendline[$j]);
    dprint 1,$s;
    if ($procdecls{$procname[$j]} ne "") {
	$s=sprintf("        declared at %s\n",
	           $procdecls{$procname[$j]});
	dprint 1,$s;
    }
    if ($noparallels{$procname[$j]} == 1) {
	dprint 1,"        annoted NOPARALLEL\n";
    }
    if (defined($proctypes{$procname[$j]})) {
	dprint 1,"        type: ".$proctypes{$procname[$j]}."\n";
    } else {
	dprint 1,"        no type?!?\n";
    }
    if (defined($variables{$procname[$j]})) {
	dprint 1,"        parameters:".
	         join("\n           ",	# Multi-line display :-)
		      split(/\,/," ,".$variables{$procname[$j]})).
		 "\n";
    } else {
	dprint 1,"        no parameters?!?\n";
    }
}
dprint 1,"\n";

dprint 1,"\nIdentifying procedure calls...\n";
dprint 1,"\n";
&find_calls();

dprint 1,"\nFound the following calls:\n\n";
for ($j=1; $j<=$procnum; $j++) {
    my $s;
    $s=sprintf("%3d) %-20s called in %s\n",
	      $j, $procname[$j], $procwherecalled[$j]);
    dprint 1,$s;
}
dprint 1,"\n";

dprint 1,"\nIdentifying recursive procedures...\n";
dprint 1,"\n";
&find_recursives();	

dprint 1,"\nFound the following recursive procedures:\n\n";
for ($j=1; $j<=$recursivenum; $j++) {
    my $s;
    my $pns = $procname[$recursives[$j]];
    $s=sprintf("%3d) %-20s", $j, $pns);
    if ($noparallels{$pns} == 1) {
	$s = sprintf("%s (annoted NOPARALLEL)", $s);
    }
    dprint 1,$s."\n";
}
dprint 1,"\n";

dprint 1,"\nParallelizing program...\n";
&parallelize_program();
dprint 1,"\n";

my $TMPFILE = $tmpfilename;
open($TMPFILE, ">".$tmpfilename) ||
 die "Cannot open temporary output file '$tmpfilename'!\n";

if ($outfilename ne "") {
    for ($j=1; $j<=$linenum; $j++) {
        print $TMPFILE $source[$j]."\n";
    }
} else {
    print "(Neither -out given nor environment PP_OUT not defined, ".
	  "printing to stdout...)\n\n";
    for ($j=1; $j<=$linenum; $j++) {
        print $TMPFILE $source[$j]."\n";
	print $source[$j]."\n";
    }
}
close($TMPFILE);

dprint 1,"\nInstrumenting resulting program...\n";
dprint 1,"\n";

# Generate parameters for instrumentation script's call
#
my $nopro = "";
if ($noprofile == 1) {		# Pass no profile flag
    $nopro = "-noprofile";
}
my $ofnam = "";
if ($outfilename ne "") {	# Pass real output file name
    $ofnam = "-out $outfilename";
}
my $dlvl = 0;			# Decrease debugging level by one for instr.
if ($debuglevel > 1) {
    $dlvl = $debuglevel - 1;
}
my $autons = "";
if ($autonostats) {		# Pass autonostats option to instrumentation
    $autons = "-autonostats";
}
my $cmd = "$instrumentprog -detail $dlvl $ofnam $nopro $autons $tmpfilename";
dprint 2,"Running: '$cmd'\n";	    
system($cmd);
unlink $tmpfilename;		# Remove temporary file

dprint 1,"done.\n";
