path: root/ghc/driver/ghc-asm-m68k.lprl

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

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 /^#(NO_)?APP/;

	if ( /^\s+/ ) { # most common case first -- a simple line!
	    # duplicated from the bottom

	    $chk[$i] .= $_;

	} elsif ( /^LC(\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;

	    die "Info table already? $symb; $i\n" if defined($infochk{$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 ( /^_(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 ( /^_[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;

    # 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

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

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

	# toss all prologue stuff;
	# be slightly paranoid to make sure there's
	# nothing surprising in there
	if ( $c =~ /--- BEGIN ---/ ) {
	    if (($p, $r) = split(/--- BEGIN ---/, $c)) {
		$p =~ s/^\tlink a6,#-?\d.*\n//;
		$p =~ s/^\tmovel d2,sp\@-\n//;
		$p =~ s/^\tmovel d5,sp\@-\n//; # SMmark.* only?
		$p =~ s/^\tmoveml \#0x[0-9a-f]+,sp\@-\n//; # SMmark.* only?
		die "Prologue junk?: $p\n" if $p =~ /^\t[^\.]/;

		# glue together what's left
		$c = $p . $r;
	    }
	}

	# toss all epilogue stuff; again, paranoidly
	if ( $c =~ /--- END ---/ ) {
	    if (($r, $e) = split(/--- END ---/, $c)) {
		$e =~ s/^\tunlk a6\n//;
		$e =~ s/^\trts\n//;
		die "Epilogue junk?: $e\n" if $e =~ /^\t[^\.]/;

		# glue together what's left
		$c = $r . $e;
	    }
	}

    	# toss all calls to __DISCARD__
	$c =~ s/^\tjbsr ___DISCARD__\n//g;

    	# toss stack adjustment after DoSparks
    	$c =~ s/^(\tjbsr _DoSparks\n)\taddqw #8,sp/$1/g;

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

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

	while ( $c =~ /^\s*(\.align\s+\d+\n|\.proc\s+\d+\n|\.const\n|\.cstring\n|\.globl\s+\S+\n|\.text\n|\.data\n|\.even\n|\.stab[^n].*\n)FUNNY#END#THING/ ) {
	    $to_move = $1;

	    if ( $to_move =~ /\.(globl|proc|stab)/ && $i < ($numchks - 1) ) {
		$chk[$i + 1] = $to_move . $chk[$i + 1];
		# otherwise they're tossed
	    }

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

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

    # print out all the literal strings first
    for ($i = 0; $i < $numchks; $i++) {
	if ( $chkcat[$i] eq 'string' ) {
	    print OUTASM "\.text\n\t\.even\n";
	    print OUTASM $chk[$i];
	    
	    $chkcat[$i] = 'DONE ALREADY';
	}
    }

    for ($i = 0; $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\.even\n";
	    print OUTASM $chk[$i];

	} elsif ( $chkcat[$i] eq 'data' ) {
	    print OUTASM "\.data\n\t\.even\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...
	    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\.even\n";
		print OUTASM $chk[$closurechk{$symb}];
		$chkcat[$closurechk{$symb}] = 'DONE ALREADY';
	    }

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

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

		# paranoia
		if ( $chk[$infochk{$symb}] =~ /\.long\s+([A-Za-z0-9_]+_entry)$/
		  && $1 ne "_${symb}_entry" ) {
		    print STDERR "!!! entry point???\n",$chk[$infochk{$symb}];
		}

		$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 _${symb}_fast\d+.*\n\tnop\n//;
		    $c =~ s/^\tjmp _${symb}_fast\d+.*\n//;
		}

		print STDERR "still has jump to fast entry point:\n$c"
		    if $c =~ /_${symb}_fast/; # NB: paranoia

		print OUTASM "\.text\n\t\.even\n";
		print OUTASM $c;
		$chkcat[$slowchk{$symb}] = 'DONE ALREADY';
	    }
	    
	    # FAST ENTRY POINT
	    if ( defined($fastchk{$symb}) ) {
		print OUTASM "\.text\n\t\.even\n";
		print OUTASM $chk[$fastchk{$symb}];
		$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\.even\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\.even\n";
		print OUTASM $chk[$directchk{$symb}];
		$chkcat[$directchk{$symb}] = 'DONE ALREADY';
	    }
	    
	} else {
	    &tidy_up_and_die(1,"$Pgm: unknown chkcat (ghc-asm m68k)\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\.long\s+/; $i++) {
	$label .= $lines[$i] . "\n",
	    next if $lines[$i] =~ /^[A-Za-z0-9_]+_info:$/
		 || $lines[$i] =~ /^\.globl/
		 || $lines[$i] =~ /^_vtbl_\S+:$/;

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

    for ( ; $i <= $#lines && $lines[$i] =~ /^\t\.long\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";
    }

    $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}