%************************************************************************
%*									*
\section[Driver-asm-fiddling]{Fiddling with assembler files (alpha)}
%*									*
%************************************************************************

Tasks:
\begin{itemize}
\item
Utterly stomp out C functions' prologues and epilogues; i.e., the
stuff to do with the C stack.
\item
Any other required tidying up.
\end{itemize}

\begin{code}
sub mangle_asm {
    local($in_asmf, $out_asmf) = @_;

    # multi-line regexp matching:
    local($*) = 1;
    local($i, $c);
    &init_FUNNY_THINGS();

    open(INASM, "< $in_asmf")
	|| &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n");
    open(OUTASM,"> $out_asmf")
	|| &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n");

    # read whole file, divide into "chunks":
    #	record some info about what we've found...

    @chk = ();		# contents of the chunk
    $numchks = 0;	# number of them
    @chkcat = ();	# what category of thing in each chunk
    @chksymb = ();	# what symbol(base) is defined in this chunk
    %slowchk = ();	# ditto, its regular "slow" entry code
    %fastchk = ();	# ditto, fast entry code
    %closurechk = ();	# ditto, the (static) closure
    %infochk = (); 	# given a symbol base, say what chunk its info tbl is in
    %vectorchk = ();    # ditto, return vector table
    %directchk = ();    # ditto, direct return code

    $i = 0;
    $chkcat[0] = 'misc';

    while (<INASM>) {
#??? 	next if /^\.stab.*___stg_split_marker/;
#??? 	next if /^\.stab.*ghc.*c_ID/;

    	next if /^\s*$/;

	if ( /^\s+/ ) { # most common case first -- a simple line!
	    # duplicated from the bottom
	    $chk[$i] .= $_;

	} elsif ( /\.\.ng:$/ ) { # Local labels not to be confused with new chunks
	    $chk[$i] .= $_;

	} elsif ( /^(ret_|djn_)/ ) {
	    $chk[++$i] .= $_;
	    $chkcat[$i] = 'misc';
	    $chksymb[$i] = '';

	} elsif ( /^vtbl_([A-Za-z0-9_]+):$/ ) {
	    $chk[++$i] .= $_;
	    $chkcat[$i] = 'vector';
	    $chksymb[$i] = $1;

	    $vectorchk{$1} = $i;

	} elsif ( /^([A-Za-z0-9_]+)DirectReturn:$/ ) {
	    $chk[++$i] .= $_;
	    $chkcat[$i] = 'direct';
	    $chksymb[$i] = $1;

	    $directchk{$1} = $i;

	} elsif ( /^[A-Za-z0-9_]+_upd:$/ ) {
	    $chk[++$i] .= $_;
	    $chkcat[$i] = 'misc';
	    $chksymb[$i] = '';

	} elsif ( /^\$C(\d+):$/ ) {
	    $chk[++$i] .= $_;
	    $chkcat[$i] = 'string';
	    $chksymb[$i] = $1;

	} elsif ( /^__stg_split_marker(\d+):$/ ) {
	    $chk[++$i] .= $_;
	    $chkcat[$i] = 'splitmarker';
	    $chksymb[$i] = $1;

	} elsif ( /^([A-Za-z0-9_]+)_info:$/ ) {
	    $symb = $1;
	    $chk[++$i] .= $_;
	    $chkcat[$i] = 'infotbl';
	    $chksymb[$i] = $symb;

	    $infochk{$symb} = $i;

	} elsif ( /^([A-Za-z0-9_]+)_entry:$/ ) {
	    $chk[++$i] .= $_;
	    $chkcat[$i] = 'slow';
	    $chksymb[$i] = $1;

	    $slowchk{$1} = $i;

	} elsif ( /^([A-Za-z0-9_]+)_fast\d+:$/ ) {
	    $chk[++$i] .= $_;
	    $chkcat[$i] = 'fast';
	    $chksymb[$i] = $1;

	    $fastchk{$1} = $i;

	} elsif ( /^([A-Za-z0-9_]+)_closure:$/ ) {
	    $chk[++$i] .= $_;
	    $chkcat[$i] = 'closure';
	    $chksymb[$i] = $1;

	    $closurechk{$1} = $i;

	} elsif ( /^ghc.*c_ID:/ ) {
	    $chk[++$i] .= $_;
	    $chkcat[$i] = 'consist';

	} elsif ( /^(__gnu_compiled_c|gcc2_compiled\.):/ ) {
	    ; # toss it

	} elsif ( /^ErrorIO_call_count:/	 # HACK!!!!
	       || /^[A-Za-z0-9_]+\.\d+:$/
	       || /^.*_CAT:/	 		# PROF: _entryname_CAT
	       || /^CC_.*_struct:/	  	# PROF: _CC_ccident_struct
	       || /^.*_done:/			# PROF: _module_done
	       || /^_module_registered:/	# PROF: _module_registered
	       ) {
	    $chk[++$i] .= $_;
	    $chkcat[$i] = 'data';
  	    $chksymb[$i] = '';

	} elsif ( /^[A-Za-z0-9_]/ ) {
	    local($thing);
	    chop($thing = $_);
	    print STDERR "Funny global thing?: $_"
		unless $KNOWN_FUNNY_THING{$thing}
		    || /^_(PRIn|PRStart).*:/	# pointer reversal GC routines
		    || /^CC_.*:/		# PROF: _CC_ccident
		    || /^_reg.*:/; 		# PROF: _reg<module>
	    $chk[++$i] .= $_;
	    $chkcat[$i] = 'misc';
	    $chksymb[$i] = '';

	} else { # simple line (duplicated at the top)
	    $chk[$i] .= $_;
	}
    }
    $numchks = $#chk + 1;

#    print STDERR "\nCLOSURES:\n";
#    foreach $s (sort (keys %closurechk)) {
#	print STDERR "$s:\t\t",$closurechk{$s},"\n";
#    }
#    print STDERR "\nINFOS:\n";
#    foreach $s (sort (keys %infochk)) {
#	print STDERR "$s:\t\t",$infochk{$s},"\n";
#    }
#    print STDERR "SLOWS:\n";
#    foreach $s (sort (keys %slowchk)) {
#	print STDERR "$s:\t\t",$slowchk{$s},"\n";
#    }
#    print STDERR "\nFASTS:\n";
#    foreach $s (sort (keys %fastchk)) {
#	print STDERR "$s:\t\t",$fastchk{$s},"\n";
#    }

    # the division into chunks is imperfect;
    # we throw some things over the fence into the next
    # chunk.
    #
    # also, there are things we would like to know
    # about the whole module before we start spitting
    # output.

    # NB: we start meddling at chunk 1, not chunk 0

    # the first ".rdata" is quite magical; as of GCC 2.7.x, it
    # spits a ".quad 0" in after the v first ".rdata"; we
    # detect this special case (tossing the ".quad 0")!
    $magic_rdata_seen = 0;

    for ($i = 1; $i < $numchks; $i++) {
	$c = $chk[$i]; # convenience copy

#	print STDERR "\nCHK $i (BEFORE):\n", $c;

	# pin a funny end-thing on (for easier matching):
	$c .= 'FUNNY#END#THING';

	if ( ! $magic_rdata_seen && $c =~ /^\s*\.rdata\n\t\.quad 0\n\t\.align \d\n/ ) {
	    $c =~ s/^\s*\.rdata\n\t\.quad 0\n\t\.align (\d)\n/\.rdata\n\t\.align $1\n/;
	    $magic_rdata_seen = 1;
	}

	# pick some end-things and move them to the next chunk

	while ( $c =~ /^(\s*\.align\s+\d+\n)FUNNY#END#THING/
	     || $c =~ /^(\s*\.(globl|ent)\s+\S+\n)FUNNY#END#THING/
             || $c =~ /^(\s*\#.*\n)FUNNY#END#THING/
             || $c =~ /^(\s*\.(file|loc)\s+\S+\s+\S+\n)FUNNY#END#THING/
	     || $c =~ /^(\s*\.text\n|\s*\.r?data\n)FUNNY#END#THING/ ) {
	    $to_move = $1;

            if ( $to_move =~ /^\s*(\#|\.(file|globl|ent|loc))/ && $i < ($numchks - 1) ) {
		$chk[$i + 1] = $to_move . $chk[$i + 1];
		# otherwise they're tossed
	    }

	    $c =~ s/^.*\nFUNNY#END#THING/FUNNY#END#THING/;
	}

    	if ($c =~ /^\t\.ent\s+(\S+)/) {
    	    $ent = $1;
	    # toss all prologue stuff, except for loading gp, and the ..ng address
	    if (($p, $r) = split(/^\t\.prologue/, $c)) {
# print STDERR "$ent: prologue:\n$p\nrest:\n$r\n";
    	        if (($keep, $junk) = split(/\.\.ng:/, $p)) {
    	    	    $c = $keep . "..ng:\n";
    	        } else {
    	    	    print STDERR "malformed code block ($ent)?\n"
    	    	}
    	    }
    	    $c .= "\t.frame \$30,0,\$26,0\n\t.prologue" . $r;
    	}

	$c =~ s/FUNNY#END#THING//;
	$chk[$i] = $c; # update w/ convenience copy

#	print STDERR "\nCHK $i (AFTER):\n", $c;
    }

    # print out the header stuff first

    $chk[0] =~ s/^(\t\.file.*)"(ghc\d+\.c)"/\1"$ifile_root.hc"/;
    print OUTASM $chk[0];

    # print out all the literal strings second
    for ($i = 1; $i < $numchks; $i++) {
	if ( $chkcat[$i] eq 'string' ) {
	    print OUTASM "\.rdata\n\t\.align 3\n";
	    print OUTASM $chk[$i];
	    
	    $chkcat[$i] = 'DONE ALREADY';
	}
    }

    for ($i = 1; $i < $numchks; $i++) {
#	print STDERR "$i: cat $chkcat[$i], symb $chksymb[$i]\n";

	next if $chkcat[$i] eq 'DONE ALREADY';

	if ( $chkcat[$i] eq 'misc' ) {
	    print OUTASM "\.text\n\t\.align 3\n";
	    print OUTASM $chk[$i];

	} elsif ( $chkcat[$i] eq 'data' ) {
	    print OUTASM "\.data\n\t\.align 3\n";
	    print OUTASM $chk[$i];

	} elsif ( $chkcat[$i] eq 'consist' ) {
	    if ( $chk[$i] =~ /\.ascii.*\)(hsc|cc) (.*)\\11"\n\t\.ascii\s+"(.*)\\0"/ ) {
		local($consist) = "$1.$2.$3";
		$consist =~ s/,/./g;
		$consist =~ s/\//./g;
		$consist =~ s/-/_/g;
		$consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly?
		print OUTASM "\.text\n$consist:\n";
	    } else {
		print STDERR "Couldn't grok consistency: ", $chk[$i];
	    }

	} elsif ( $chkcat[$i] eq 'splitmarker' ) {
	    # we can just re-constitute this one...
    	    # ignore the final split marker, to save an empty object module
    	    # Use _three_ underscores so that ghc-split doesn't get overly complicated
	    print OUTASM "___stg_split_marker",$chksymb[$i],":\n";

	} elsif ( $chkcat[$i] eq 'closure'
	       || $chkcat[$i] eq 'infotbl'
	       || $chkcat[$i] eq 'slow'
	       || $chkcat[$i] eq 'fast' ) { # do them in that order
	    $symb = $chksymb[$i];

	    # CLOSURE
	    if ( defined($closurechk{$symb}) ) {
		print OUTASM "\.data\n\t\.align 3\n";
		print OUTASM $chk[$closurechk{$symb}];
		$chkcat[$closurechk{$symb}] = 'DONE ALREADY';
	    }

	    # INFO TABLE
	    if ( defined($infochk{$symb}) ) {

		print OUTASM "\.text\n\t\.align 3\n";
		print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1);
		# entry code will be put here!

		$chkcat[$infochk{$symb}] = 'DONE ALREADY';
	    }

	    # STD ENTRY POINT
	    if ( defined($slowchk{$symb}) ) {

    		# teach it to drop through to the fast entry point:
		$c = $chk[$slowchk{$symb}];
    	    	if ( defined($fastchk{$symb}) ) {
    		    $c =~ s/^\tjmp \$31,\(\$27\),0\n\t\.align 4\n\t\.end/\t.align 4\n\t.end/;
    	    	}

		print OUTASM "\.text\n\t\.align 3\n";
		print OUTASM $c;
		$chkcat[$slowchk{$symb}] = 'DONE ALREADY';
	    }
	    
	    # FAST ENTRY POINT
	    if ( defined($fastchk{$symb}) ) {
    	    	$c = $chk[$fastchk{$symb}];
    	    	if ( ! defined($slowchk{$symb}) ) {
		    print OUTASM "\.text\n\t\.align 3\n";
    	    	}
		print OUTASM $c;
		$chkcat[$fastchk{$symb}] = 'DONE ALREADY';
	    }

	} elsif ( $chkcat[$i] eq 'vector'
	       || $chkcat[$i] eq 'direct' ) { # do them in that order
	    $symb = $chksymb[$i];

	    # VECTOR TABLE
	    if ( defined($vectorchk{$symb}) ) {
		print OUTASM "\.text\n\t\.align 3\n";
		print OUTASM &rev_tbl($symb, $chk[$vectorchk{$symb}], 0);
		# direct return code will be put here!
		$chkcat[$vectorchk{$symb}] = 'DONE ALREADY';
	    }

	    # DIRECT RETURN
	    if ( defined($directchk{$symb}) ) {
		print OUTASM "\.text\n\t\.align 3\n";
		print OUTASM $chk[$directchk{$symb}];
		$chkcat[$directchk{$symb}] = 'DONE ALREADY';
	    } else {
                # The commented nop is for the splitter, to ensure
                # that no module ends with a label as the very last
                # thing.  (The linker will adjust the label to point
                # to the first code word of the next module linked in,
                # even if alignment constraints cause the label to move!)

		print OUTASM "\t# nop\n";
	    }
	} else {
	    &tidy_up_and_die(1,"$Pgm: unknown chkcat (ghc-asm alpha)\n$chkcat[$i]\n$chk[$i]\n");
	}
    }

    # finished:
    close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n");
    close(INASM)  || &tidy_up_and_die(1,"Failed reading from $in_asmf\n");
}
\end{code}

\begin{code}
sub init_FUNNY_THINGS {
    %KNOWN_FUNNY_THING = (
	'CheckHeapCode:', 1,
	'CommonUnderflow:', 1,
	'Continue:', 1,
	'EnterNodeCode:', 1,
	'ErrorIO_call_count:', 1,
	'ErrorIO_innards:', 1,
	'IndUpdRetDir:', 1,
	'IndUpdRetV0:', 1,
	'IndUpdRetV1:', 1,
	'IndUpdRetV2:', 1,
	'IndUpdRetV3:', 1,
	'IndUpdRetV4:', 1,
	'IndUpdRetV5:', 1,
	'IndUpdRetV6:', 1,
	'IndUpdRetV7:', 1,
	'PrimUnderflow:', 1,
	'StackUnderflowEnterNode:', 1,
	'StdErrorCode:', 1,
	'UnderflowVect0:', 1,
	'UnderflowVect1:', 1,
	'UnderflowVect2:', 1,
	'UnderflowVect3:', 1,
	'UnderflowVect4:', 1,
	'UnderflowVect5:', 1,
	'UnderflowVect6:', 1,
	'UnderflowVect7:', 1,
	'UpdErr:', 1,
	'UpdatePAP:', 1,
	'WorldStateToken:', 1,
	'_Enter_Internal:', 1,
	'_PRMarking_MarkNextAStack:', 1,
	'_PRMarking_MarkNextBStack:', 1,
	'_PRMarking_MarkNextCAF:', 1,
	'_PRMarking_MarkNextGA:', 1,
	'_PRMarking_MarkNextRoot:', 1,
	'_PRMarking_MarkNextSpark:', 1,
	'_Scavenge_Forward_Ref:', 1,
	'__std_entry_error__:', 1,
	'_startMarkWorld:', 1,
	'resumeThread:', 1,
	'startCcRegisteringWorld:', 1,
	'startEnterFloat:', 1,
	'startEnterInt:', 1,
	'startPerformIO:', 1,
	'startStgWorld:', 1,
	'stopPerformIO:', 1
  );
}
\end{code}

The following table reversal is used for both info tables and return
vectors.  In both cases, we remove the first entry from the table,
reverse the table, put the label at the end, and paste some code
(that which is normally referred to by the first entry in the table)
right after the table itself.  (The code pasting is done elsewhere.)

\begin{code}
sub rev_tbl {
    local($symb, $tbl, $discard1) = @_;

    local($before) = '';
    local($label) = '';
    local(@words) = ();
    local($after) = '';
    local(@lines) = split(/\n/, $tbl);
    local($i);

    for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t\.quad\s+/; $i++) {
	$label .= $lines[$i] . "\n",
	    next if $lines[$i] =~ /^[A-Za-z0-9_]+:$/
		 || $lines[$i] =~ /^\t\.globl/;

	$before .= $lines[$i] . "\n"; # otherwise...
    }

    for ( ; $i <= $#lines && $lines[$i] =~ /^\t\.quad\s+/; $i++) {
	push(@words, $lines[$i]);
    }
    # now throw away the first word (entry code):
    shift(@words) if $discard1;

    for (; $i <= $#lines; $i++) {
	$after .= $lines[$i] . "\n";
    }

    # If we have anonymous text (not part of a procedure), the linker
    # may complain about missing exception information.  Bleh.
    if ($label =~ /^([A-Za-z0-9_]+):$/) {
    	$before = "\t.ent $1\n" . $before;
    	$after .= "\t.end $1\n";
    }

    $tbl = $before . join("\n", (reverse @words)) . "\n" . $label . $after;

#    print STDERR "before=$before\n";
#    print STDERR "label=$label\n";
#    print STDERR "words=",(reverse @words),"\n";
#    print STDERR "after=$after\n";

    $tbl;
}
\end{code}

%************************************************************************
%*									*
\subsection[Driver-asm-info]{Collect interesting (static) info from an assembler file}
%*									*
%************************************************************************

How many times is each asm instruction used?

\begin{code}
%AsmInsn = (); # init

sub dump_asm_insn_counts {
    local($asmf) = @_;

    open(INASM, "< $asmf")  || &tidy_up_and_die(1,"$Pgm: failed to open `$asmf' (to read)\n");
    while (<INASM>) {
	if ( /^\t([a-z][a-z0-9]+)\b/ ) {
	    $AsmInsn{$1} ++;
	}
    }
    close(INASM) || &tidy_up_and_die(1,"Failed reading from $asmf\n");

    # OK, now print what we collected (to stderr)
    foreach $i (sort (keys %AsmInsn)) {
	print STDERR "INSN:: $i\t",$AsmInsn{$i},"\n";
    }
}

sub dump_asm_globals_info {
}

# make "require"r happy...
1;
\end{code}