instructions.c

/*
	(Concurrent) Clean Compiler: ABC instructions
	Authors:  Sjaak Smetsers & John van Groningen
*/

#include "compiledefines.h"
#include "comsupport.h"

#include <ctype.h>

#include "syntaxtr.t"
#include "checksupport.h"

#include "settings.h"
#include "sizes.h"
#include "codegen_types.h"
#include "codegen1.h"
#include "codegen2.h"
#include "instructions.h"
#include "statesgen.h"
#include "version.h"

#define for_l(v,l,n) for(v=(l);v!=NULL;v=v->n)

#define BINARY_ABC 0
#undef MEMORY_PROFILING_WITH_N_STRING

#define PutSOutFile(s) FPutS ((s),OutFile)
#define PutCOutFile(s) FPutC ((s),OutFile)

static void error_in_function (char *m)
{
	ErrorInCompiler ("instructions.c",m,"");
}

/* also defined in project.c, only needed for stand alone compiler */

#define N_DoDebug				0
#define N_DoReuseUniqueNodes	1
#define N_DoParallel			2

#define N_NoDescriptors 3
/*
#define N_NoMemoryProfiling		3
*/
#define N_DoStrictnessAnalysis	4
#define N_NoTimeProfiling		5
#define N_ExportLocalLabels 6
#define N_DoWarning				7
#define N_System				8
#define N_DoFusion				9
#define N_Do64BitArch			10
#define N_Dynamics				11
#define N_DoGenericFusion		12

#define MINIMUM_N_OPTIONS 9
#define N_OPTIONS 13

static void ConvertOptionsToString (char *optstring)
{
	optstring[N_DoDebug]              = DoDebug ? '1' : '0';
	optstring[N_DoReuseUniqueNodes]   = !DoReuseUniqueNodes ? '1' : '0';
	optstring[N_DoParallel]           = DoParallel ? '1' : '0';

	optstring[N_NoDescriptors] = !DoDescriptors ? '1' : '0';
/*
	optstring[N_NoMemoryProfiling]    = !DoProfiling ? '1' : '0';
*/
	optstring[N_DoStrictnessAnalysis] = DoStrictnessAnalysis ? '1' : '0';

	optstring[N_NoTimeProfiling]      = !DoTimeProfiling ? '1' : '0';
	optstring[N_ExportLocalLabels] = ExportLocalLabels ? '1' : '0';
	optstring[N_DoWarning]            = DoWarning ? '1' : '0';
	optstring[N_System]               = '0';

	if (DoFusion || ObjectSizes[RealObj]!=2 || Dynamics || DoGenericFusion){
		optstring[N_DoFusion] = DoFusion ? '1' : '0';
		optstring[N_Do64BitArch] = ObjectSizes[RealObj]!=2 ? '1' : '0';
		optstring[N_Dynamics] = Dynamics ? '1' : '0';
		optstring[N_DoGenericFusion] = DoGenericFusion ? '1' : '0';
		optstring[N_OPTIONS]='\0';
	} else
		optstring[MINIMUM_N_OPTIONS]='\0';
}

#define D_PREFIX "d"
#define N_PREFIX "n"
#define L_PREFIX "l"

#define EA_PREFIX "ea"
#define EU_PREFIX "eu"
#define S_PREFIX "s"

#define R_PREFIX "r"
#define RECORD_N_PREFIX "c"
#define RECORD_D_PREFIX "t"
#define CONSTRUCTOR_R_PREFIX "k"

#define LOCAL_D_PREFIX "d"

File OutFile;
char *ABCFileName;

Bool OpenABCFile (char *fname)
{
	OutFile = FOpen (fname, "w");

	if (OutFile!=NULL){
#if defined (POWER)
		setvbuf ((FILE*) OutFile, NULL, _IOFBF, 8192);
#endif
		OpenedFile = OutFile;
		ABCFileName = fname;
		return True;
	} else
		return False;
}

void WriteLastNewlineToABCFile (void)
{
	PutCOutFile ('\n');
}

void CloseABCFile (char *fname)
{
	if (OutFile){
		if (FClose (OutFile) != 0){
			CompilerError = True;
			CurrentLine = 0;
			
			StaticMessage_s_s (True, "<open file>", "Write error (disk full?)");
		}
		if (CompilerError)
			FDelete (fname);
		OpenedFile = (File) NIL;
	}
}

static Bool DescriptorNeeded (SymbDef sdef)
{
	return (sdef->sdef_exported || 
			(sdef->sdef_kind!=IMPRULE && sdef->sdef_kind!=SYSRULE) || 
			sdef->sdef_mark & SDEF_USED_CURRIED_MASK) ||
			((DoParallel || DoDescriptors) && (sdef->sdef_mark & (SDEF_USED_CURRIED_MASK | SDEF_USED_LAZILY_MASK)));
}

static void Put_SOutFile (char *s)
{
	PutCOutFile (' ');
	PutSOutFile (s);
}

static void PutSSOutFile (char *s1,char *s2)
{
	PutSOutFile (s1);
	PutSOutFile (s2);
}

static void GenLabel (Label label)
{
	if (label->lab_issymbol){
		SymbDef def;
		char *module_name;

		def=label->lab_symbol;
		module_name = label->lab_mod;
		
		if (module_name!=NULL)
			FPrintF (OutFile,"e_%s_%s%s",module_name,label->lab_pref,def->sdef_name);
		else if (DoDebug){
			if (def->sdef_kind==IMPRULE)
				FPrintF (OutFile, "%s%s.%u",label->lab_pref,def->sdef_name,def->sdef_number);
			else
				FPrintF (OutFile, "%s%s",label->lab_pref,def->sdef_name);
		} else if (def->sdef_number==0)
			PutSSOutFile (label->lab_pref,def->sdef_name);
		else if (label->lab_pref[0] == '\0')
			FPrintF (OutFile,LOCAL_D_PREFIX "%u",def->sdef_number);
		else
			FPrintF (OutFile,"%s%u",label->lab_pref,def->sdef_number);
	} else {
		PutSOutFile (label->lab_pref);
		PutSOutFile (label->lab_name);
	}
	if (label->lab_post!=0)
		FPrintF (OutFile,".%u",label->lab_post);
}

static void GenDescriptorOrNodeEntryLabel (Label label)
{
	if (label->lab_issymbol){
		SymbDef def;
		char *module_name;

		def=label->lab_symbol;
		module_name = label->lab_mod;
		
		if (module_name!=NULL)
			FPrintF (OutFile,"e_%s_%s%s",module_name,label->lab_pref,def->sdef_name);
		else if (ExportLocalLabels){
			if (def->sdef_kind==IMPRULE)
				FPrintF (OutFile,"e_%s_%s%s.%u",CurrentModule,label->lab_pref,def->sdef_name,def->sdef_number);
			else
				FPrintF (OutFile,"e_%s_%s%s",CurrentModule,label->lab_pref,def->sdef_name);
		} else if (DoDebug){
			if (def->sdef_kind==IMPRULE)
				FPrintF (OutFile, "%s%s.%u",label->lab_pref,def->sdef_name,def->sdef_number);
			else
				PutSSOutFile (label->lab_pref,def->sdef_name);
		} else if (def->sdef_number==0)
			PutSSOutFile (label->lab_pref,def->sdef_name);
		else if (label->lab_pref[0] == '\0')
			FPrintF (OutFile,LOCAL_D_PREFIX "%u",def->sdef_number);
		else
			FPrintF (OutFile,"%s%u",label->lab_pref,def->sdef_number);
	} else {
		PutSOutFile (label->lab_pref);
		PutSOutFile (label->lab_name);
	}
	if (label->lab_post!=0)
		FPrintF (OutFile,".%u",label->lab_post);
}

#if !BINARY_ABC

#define put_instructionb(a) put_instruction(I##a)
#define put_instruction_b(a) put_instruction_(I##a)
#define put_directiveb(a) put_directive(D##a)
#define put_directive_b(a) put_directive_(D##a)
#define put_arguments_i_b(i1) FPrintF (OutFile," %s",(i1))
#define put_arguments_in_b(i1,n1) FPrintF (OutFile," %s %d",(i1),(n1))
#define put_argumentsn_b(n1) FPrintF (OutFile,"%d",(n1))
#define put_argumentsnn_b(n1,n2) FPrintF (OutFile,"%d %d",(n1),(n2))
#define put_arguments_nnn_b(n1,n2,n3) FPrintF (OutFile," %d %d %d",(n1),(n2),(n3))
#define put_arguments_nnnn_b(n1,n2,n3,n4) FPrintF (OutFile," %d %d %d %d",(n1),(n2),(n3),(n4))
#define put_arguments_nnnnn_b(n1,n2,n3,n4,n5) FPrintF (OutFile," %d %d %d %d %d",(n1),(n2),(n3),(n4),(n5))
#define put_argumentsn__b(n1) FPrintF (OutFile,"%d ",(n1))
#define put_arguments_nn__b(n1,n2) FPrintF (OutFile," %d %d ",(n1),(n2))
#define put_arguments_n_b(n1) FPrintF (OutFile," %d",(n1))
#define put_arguments_nn_b(n1,n2) FPrintF (OutFile," %d %d",(n1),(n2))
#define put_arguments_n__b(n1) FPrintF (OutFile," %d ",(n1))

#else

/*
#define put_instructionb(a) put_instruction_code(C##a)
#define put_instruction_b(a) put_instruction_code(C##a)
#define put_directive_b(a) put_instruction_code(C##a)
*/

#define put_instructionb(a) if (DoDebug) put_instruction(I##a); else put_instruction_code(C##a)
#define put_instruction_b(a) if (DoDebug) put_instruction_(I##a); else put_instruction_code(C##a)
#define put_directiveb(a) if (DoDebug) put_directive(D##a); else put_instruction_code(C##a)
#define put_directive_b(a) if (DoDebug) put_directive_(D##a); else put_instruction_code(C##a)

static void put_n (long n)
{
	while (!(n>=-64 && n<=63)){
		PutCOutFile (128+(n & 127));
		n=n>>7;
	}

	PutCOutFile (n+64);
}

static long integer_string_to_integer (char *s_p)
{
	long integer;
	int minus_sign,last_char;
	
	minus_sign=0;
	last_char=*s_p++;
	if (last_char=='+' || last_char=='-'){
		if (last_char=='-')
			minus_sign=!minus_sign;
		last_char=*s_p++;;
	}
			
	integer=last_char-'0';
	last_char=*s_p++;;
	
	while ((unsigned)(last_char-'0')<10u){
		integer*=10;
		integer+=last_char-'0';
		last_char=*s_p++;;
	}
		
	if (minus_sign)
		integer=-integer;
	
	return integer;
}

static void put_arguments_i_b (char *i1)
{
	if (DoDebug){
		PutCOutFile (' ');
		PutSOutFile (i1);
	} else
		put_n (integer_string_to_integer (i1));
}

static void put_arguments_in_b (char *i1,long n1)
{
	if (DoDebug)
		FPrintF (OutFile," %s %d",(i1),(n1));
	else {
		put_n (integer_string_to_integer (i1));
		put_n (n1);
	}
}

static void put_argumentsn_b (long n1)
{
	if (DoDebug)
		FPrintF (OutFile,"%d",(n1));
	else
		put_n (n1);
}

static void put_argumentsnn_b (long n1,long n2)
{
	if (DoDebug)
		FPrintF (OutFile,"%d %d",(n1),(n2));
	else {
		put_n (n1);
		put_n (n2);
	}
}

static void put_arguments_nnn_b (long n1,long n2,long n3)
{
	if (DoDebug)
		FPrintF (OutFile," %d %d %d",(n1),(n2),(n3));
	else {
		put_n (n1);
		put_n (n2);
		put_n (n3);
	}
}

static void put_arguments_nnnn_b (long n1,long n2,long n3,long n4)
{
	if (DoDebug)	
		FPrintF (OutFile," %d %d %d %d",(n1),(n2),(n3),(n4));
	else {
		put_n (n1);
		put_n (n2);
		put_n (n3);
		put_n (n4);
	}
}

static void put_arguments_nnnnn_b (long n1,long n2,long n3,long n4,long n5)
{
	if (DoDebug)
		FPrintF (OutFile," %d %d %d %d %d",(n1),(n2),(n3),(n4),(n5));
	else {
		put_n (n1);
		put_n (n2);
		put_n (n3);
		put_n (n4);
		put_n (n5);
	}
}

static void put_argumentsn__b (long n1)
{
	if (DoDebug)
		FPrintF (OutFile,"%d ",(n1));
	else
		put_n (n1);
}

static void put_arguments_n_b (long n1)
{
	if (DoDebug)
		FPrintF (OutFile," %d",(n1));
	else {
		PutCOutFile (' ',OutFile);
		put_n (n1);
	}
}

static void put_arguments_n__b (long n1)
{
	if (DoDebug)
		FPrintF (OutFile," %d ",(n1));
	else {
		PutCOutFile (' ',OutFile);
		put_n (n1);
	}
}

static void put_arguments_nn__b (long n1,long n2)
{
	if (DoDebug)
		FPrintF (OutFile," %d %d ",(n1),(n2));
	else {
		put_n (n1);
		put_n (n2);
	}
}

static void put_arguments_nn_b (long n1,long n2)
{
	if (DoDebug)
		FPrintF (OutFile," %d %d",(n1),(n2));
	else {
		PutCOutFile (' ',OutFile);
		put_n (n1);
		put_n (n2);
	}
}

enum {
	Cbuild=136,
	Cbuildh,
	CbuildI,
	CbuildB_b,
	CbuildC_b,
	CbuildI_b,
	CbuildR_b,
	CbuildF_b,
	Ceq_desc,
	CeqD_b,
	CeqI_a,
	CeqI_b,
	Cfill,
	Cfillh,
	CfillI,
	CfillB_b,
	CfillC_b,
	CfillF_b,
	CfillI_b,
	CfillR_b,
	Cfill_a,
	Cjmp,
	Cjmp_false,
	Cjmp_true,
	Cjsr,
	Cjsr_eval,
	Cpop_a,
	Cpop_b,
	CpushB_a,
	CpushC_a,
	CpushI_a,
	CpushF_a,
	CpushR_a,
	CpushD,
	CpushI,
	Cpush_a,
	Cpush_b,
	Cpush_arg,
	Cpush_args,
	Cpush_args_u,
	Cpush_node,
	Cpush_node_u,
	Cpush_r_args,
	Cpush_r_args_a,
	Cpush_r_args_b,
	Cpush_r_args_u,
	Crepl_arg,
	Crepl_args,
	Crepl_r_args,
	Crepl_r_args_a,
	Crtn,
	Cupdate_a,
	Cupdate_b,
	Cupdatepop_a,
	Cupdatepop_b,
	
	Cd,
	Co,
	Cimpdesc,
	Cimplab,
	Cimpmod,
	Cn
};
#endif

#define IbuildB "buildB"
#define IbuildC "buildC"
#define IbuildI "buildI"
#define IbuildR "buildR"

#define IbuildB_b "buildB_b"
#define IbuildC_b "buildC_b"
#define IbuildF_b "buildF_b"
#define IbuildI_b "buildI_b"
#define IbuildR_b "buildR_b"

#define IfillB "fillB"
#define IfillC "fillC"
#define IfillI "fillI"
#define IfillR "fillR"

#define IfillB_b "fillB_b"
#define IfillC_b "fillC_b"
#define IfillI_b "fillI_b"
#define IfillR_b "fillR_b"
#define IfillF_b "fillF_b"

#define IeqB_a "eqB_a"
#define IeqC_a "eqC_a"
#define IeqI_a "eqI_a"
#define IeqR_a "eqR_a"

#define IeqAC_a "eqAC_a"

#define IeqB_b "eqB_b"
#define IeqC_b "eqC_b"
#define IeqI_b "eqI_b"
#define IeqR_b "eqR_b"

#define InotB "notB"

#define IpushB "pushB"
#define IpushI "pushI"
#define IpushC "pushC"
#define IpushR "pushR"
#define IpushZR "pushZR"
#define IpushZ "pushZ"

#define IpushD "pushD"

#define IpushB_a "pushB_a"
#define IpushC_a "pushC_a"
#define IpushI_a "pushI_a"
#define IpushR_a "pushR_a"
#define IpushF_a "pushF_a"

#define IpushD_a "pushD_a"

#define Ipush_array "push_array"
#define Ipush_arraysize "push_arraysize"
#define Iselect "select"
#define Iupdate "update"
#define Ireplace "replace"

#define Ipush_arg "push_arg"
#define Ipush_args "push_args"
#define Ipush_args_u "push_args_u"
#define Ipush_r_args "push_r_args"
#define Ipush_r_args_u "push_r_args_u"
#define Ipush_r_args_a "push_r_args_a"
#define Ipush_r_args_b "push_r_args_b"
#define Ipush_r_arg_u "push_r_arg_u"
#define Irepl_arg "repl_arg"
#define Irepl_args "repl_args"
#define Irepl_r_args "repl_r_args"
#define Irepl_r_args_a "repl_r_args_a"

#define Ipush_node "push_node"
#define Ipush_node_u "push_node_u"

#define Ifill "fill"
#define Ifillcp "fillcp"
#define Ifill_u "fill_u"
#define Ifillcp_u "fillcp_u"
#define Ifillh "fillh"
#define Ifill1 "fill1"
#define Ifill2 "fill2"
#define Ifill3 "fill3"

#define Ibuild "build"
#define Ibuildh "buildh"
#define Ibuild_u "build_u"
#define IbuildAC "buildAC"

#define Ifill_r "fill_r"
#define Ifill1_r "fill1_r"
#define Ifill2_r "fill2_r"
#define Ifill3_r "fill3_r"

#define Ibuildhr "buildhr"
#define Ibuild_r "build_r"

#define Ifill_a "fill_a"

#define Ipush_a "push_a"
#define Ipush_b "push_b"

#define Ijsr_eval "jsr_eval"
#define Ijsr_ap "jsr_ap"
#define Ijsr_i "jsr_i"

#define Ipop_a "pop_a"
#define Ipop_b "pop_b"
#define Ieq_desc "eq_desc"
#define IeqD_b "eqD_b"

#define Ijmp_false "jmp_false"
#define Ijmp_true "jmp_true"
#define Ijmp "jmp"
#define Ijsr "jsr"

#define Icreate "create"
#define Iprint "print"

#define Iupdate_a "update_a"
#define Iupdate_b "update_b"
#define Iupdatepop_a "updatepop_a"
#define Iupdatepop_b "updatepop_b"
#define Iupdate_b "update_b"
#define Ipop_a "pop_a"
#define Ipop_b "pop_b"

#define Iget_node_arity "get_node_arity"
#define Iget_desc_arity "get_desc_arity"

#define Ipush_arg_b "push_arg_b"

#define Irtn "rtn"

#define Ijmp_eval "jmp_eval"
#define Ijmp_eval_upd "jmp_eval_upd"
#define Ijmp_ap "jmp_ap"
#define Ijmp_ap_upd "jmp_ap_upd"
#define Ijmp_i "jmp_i"
#define Ijmp_not_eqZ "jmp_not_eqZ"
#define Ijmp_upd "jmp_upd"

#define Ihalt "halt"

#define Itestcaf "testcaf"
#define Ipushcaf "pushcaf"
#define Ifillcaf "fillcaf"

#define Iin "in"
#define Iout "out"

static void put_instruction (char *instruction)
{
	PutCOutFile ('\n');
	PutCOutFile ('\t');
	PutSOutFile (instruction);
}

static void put_instruction_ (char *instruction)
{
	PutCOutFile ('\n');
	PutCOutFile ('\t');
	PutSOutFile (instruction);
	PutCOutFile (' ');
}

static void put_instruction_code (int instruction_code)
{
	PutCOutFile (instruction_code);
}

static void GenGetWL (int offset)
{
	put_instruction ("getWL");
	put_arguments_n_b (offset);
}

static void GenPutWL (int offset)
{
	put_instruction ("putWL");
	put_arguments_n_b (offset);
}

static void GenRelease (void)
{
	put_instruction ("release");
}

static void TreatWaitListBeforeFill (int offset, FillKind fkind)
{
	if (DoParallel && fkind != NormalFill)
		GenGetWL (offset);	
}

static void TreatWaitListAfterFill (int offset, FillKind fkind)
{
	if (DoParallel){
		switch (fkind){
			case ReleaseAndFill:GenRelease ();		break;
			case PartialFill:	GenPutWL (offset);	break;
			default:							break;
		}
	}
}

#define Da "a"
#define Dai "ai"
#define Dkeep "keep"
#define Dd "d"
#define Do "o"
#define Dimpdesc "impdesc"
#define Dimplab "implab"
#define Dimpmod "impmod"
#define Dexport "export"
#define Dn "n"
#define Dnu "nu"
#define Dn_string "n_string"
#define Ddesc "desc"
#define Ddesc0 "desc0"
#define Ddescn "descn"
#define Ddescs "descs"
#define Ddescexp "descexp"
#define Drecord "record"
#define Dmodule "module"
#define Ddepend "depend"
#define Dcomp "comp"
#define Dstart "start"
#define Dstring "string"
#define Dcaf "caf"
#define Dendinfo "endinfo"

#define Dpb "pb"
#define Dpd "pd"
#define Dpn "pn"
#define Dpl "pl"
#define Dpld "pld"
#define Dpt "pt"
#define Dpe "pe"

static void put_directive (char *directive)
{
	PutCOutFile ('\n');
	PutCOutFile ('.');
	PutSOutFile (directive);
}

static void put_directive_ (char *directive)
{
	PutCOutFile ('\n');
	PutCOutFile ('.');
	PutSOutFile (directive);
	PutCOutFile (' ');
}

static void put_first_directive (char *directive)
{
	PutCOutFile ('.');
	PutSOutFile (directive);
}

void BuildBasicFromB (ObjectKind kind,int b_offset)
{
	switch (kind){
		case IntObj:
		case ProcIdObj:
		case RedIdObj:
			put_instructionb (buildI_b); break;
		case BoolObj:
			put_instructionb (buildB_b); break;
		case CharObj:
			put_instructionb (buildC_b); break;
		case RealObj:
			put_instructionb (buildR_b); break;
		case FileObj:
			put_instructionb (buildF_b); break;
		default:
			error_in_function ("BuildBasicFromB");
			return;
	}

	put_arguments_n_b (b_offset);
}

void FillBasicFromB (ObjectKind kind, int boffs, int aoffs, FillKind fkind)
{
	TreatWaitListBeforeFill (aoffs, fkind);
	switch (kind){
		case IntObj:
		case ProcIdObj:			/* we assume proc_id and red_id	*/
		case RedIdObj:			/* to be integers				*/
			put_instructionb (fillI_b); break;
		case BoolObj:
			put_instructionb (fillB_b); break;
		case CharObj:
			put_instructionb (fillC_b); break;
		case RealObj:
			put_instructionb (fillR_b); break;
		case FileObj:
			put_instructionb (fillF_b); break;
		default:
			error_in_function ("FillBasicFromB");
			return;
	}
	put_arguments_nn_b (boffs,aoffs);
	TreatWaitListAfterFill (aoffs, fkind);
}

void BuildBasic (ObjectKind obj,SymbValue val)
{
	switch (obj){
		case IntObj:
			put_instructionb (buildI);
			put_arguments_i_b (val.val_int);
			break;
		case BoolObj:
			put_instruction_ (IbuildB);
			PutSOutFile (val.val_bool ? "TRUE" : "FALSE");
			break;
		case CharObj:
			put_instruction (IbuildC);
			Put_SOutFile (val.val_char);
			break;
		case RealObj:
			put_instruction (IbuildR);
			Put_SOutFile (val.val_real);
			break;
		default:
			error_in_function ("BuildBasic");
			return;
	}
}

void FillBasic (ObjectKind obj, SymbValue val, int offset, FillKind fkind)
{
	TreatWaitListBeforeFill (offset, fkind);
	switch (obj){
		case IntObj:
			put_instructionb (fillI);
			put_arguments_in_b (val.val_int,offset);
			break;
		case BoolObj:
			put_instruction (IfillB);
			PutSOutFile (val.val_bool ? " TRUE" : " FALSE");
			put_arguments_n_b (offset);
			break;
		case CharObj:
			put_instruction (IfillC);
			Put_SOutFile (val.val_char);
			put_arguments_n_b (offset);
			break;
		case RealObj:
			put_instruction (IfillR);
			Put_SOutFile (val.val_real);
			put_arguments_n_b (offset);
			break;
		default:
			error_in_function ("FillBasic");
			return;
	}
	TreatWaitListAfterFill (offset, fkind);
}

void IsBasic (ObjectKind obj, SymbValue val, int offset)
{
	switch (obj){
		case IntObj:
			put_instructionb (eqI_a);
			put_arguments_in_b (val.val_int,offset);
			return;
		case BoolObj:
			put_instruction (IeqB_a);
			PutSOutFile (val.val_bool ? " TRUE" : " FALSE");
			break;
		case CharObj:
			put_instruction (IeqC_a);
			Put_SOutFile (val.val_char);
			break;
		case RealObj:
			put_instruction (IeqR_a);
			Put_SOutFile (val.val_real);
			break;
		default:
			error_in_function ("IsBasic");
			return;
	}
	put_arguments_n_b (offset);
}

void IsString (SymbValue val)
{
	put_instruction_ (IeqAC_a);
	PutSOutFile (val.val_string);
}

void PushBasic (ObjectKind obj, SymbValue val)
{
	switch (obj){
		case IntObj:
			put_instructionb (pushI);
			put_arguments_i_b (val.val_int);
			break;
		case BoolObj:
			put_instruction_ (IpushB);
			PutSOutFile (val.val_bool ? "TRUE" : "FALSE");
			break;
		case CharObj:
			put_instruction (IpushC);
			Put_SOutFile (val.val_char);
			break;
		case RealObj:
			put_instruction_ (IpushR);
			PutSOutFile (val.val_real);
			break;
		default:
			error_in_function ("PushBasic");
			return;
	}
}

void GenPushReducerId (int i)
{
	put_instructionb (pushI);
	put_arguments_n_b (i);
}

void GenPushArgNr (int argnr)
{
	put_instructionb (pushI);
	put_arguments_n_b (argnr);
}

void EqBasic (ObjectKind obj, SymbValue val, int offset)
{
	switch (obj){
		case IntObj:
			put_instructionb (eqI_b);
			put_arguments_in_b (val.val_int,offset);
			return;
		case BoolObj:
			put_instruction (IeqB_b);
			PutSOutFile (val.val_bool ? " TRUE" : " FALSE");
			break;
		case CharObj:
			put_instruction (IeqC_b);
			Put_SOutFile (val.val_char);
			break;
		case RealObj:
			put_instruction (IeqR_b);
			Put_SOutFile (val.val_real);
			break;
		default:
			error_in_function ("EqBasic");
			return;
	}
	put_arguments_n_b (offset);
}

void GenNotB (void)
{
	put_instruction (InotB);
}

void PushBasicFromAOnB (ObjectKind kind,int offset)
{
	switch (kind){
		case IntObj:
		case ProcIdObj:
		case RedIdObj:
			put_instructionb (pushI_a);
			break;
		case BoolObj:
			put_instructionb (pushB_a);
			break;
		case CharObj:
			put_instructionb (pushC_a);
			break;
		case RealObj:
			put_instructionb (pushR_a);
			break;
		case FileObj:
			put_instructionb (pushF_a);
			break;
		default:
			error_in_function ("PushBasicFromAOnB");
			return;
	}
	put_arguments_n_b (offset);
}

void GenPushD_a (int a_offset)
{
	put_instruction (IpushD_a);
	put_arguments_n_b (a_offset);
}
	
void PushBasicOnB (ObjectKind obj, int offset)
{
	int i;

	for (i = ObjectSizes[obj]; i > 0; i--)
		GenPushB (offset + ObjectSizes[obj] - 1);
}

void UpdateBasic (int size, int srcoffset, int dstoffset)
{
	if (srcoffset < dstoffset){
		int i;
		
		for (i=size-1; i >= 0; i--)
			GenUpdateB (srcoffset+i, dstoffset+i);
	} else if (srcoffset > dstoffset){
		int i;
		
		for (i=0; i < size; i++)
			GenUpdateB (srcoffset+i, dstoffset+i);
	}
}

static Bool IsDirective (Instructions instruction, char *directive)
{
	char *s;

	s=instruction->instr_this;
	while (isspace(*s))
		++s;
	if (*s!='.')
		return False;

	for (; *directive; ++directive)
		if (*directive!=*++s)
			return False;

	return True;
}

static Bool IsInlineFromCurrentModule (SymbDef def)
{
	RuleAlts alt;
	Instructions instruction, next;
	/*
	if (def->sdef_kind!=IMPRULE)
		return False;
	*/
	alt=def->sdef_rule->rule_alts;

	if (alt->alt_kind!=ExternalCall || !alt->alt_rhs_code->co_is_abc_code)
		return False;
	
	instruction=alt->alt_rhs_code->co_instr;

	if (!IsDirective(instruction, "inline"))
		return False;

	for (instruction=instruction->instr_next;(next=instruction->instr_next)!=NULL;instruction=next)
		;

	return (IsDirective(instruction, "end"));
}

/*
	For ABC to target machine code generation we supply the abc code
	with special stack layout directives. The routines for doing this
	are 'GenBStackElems', 'GenStackLayoutOfNode' and 'GenStackLayoutOfState'.
*/

static char BElems[] = BASIC_ELEMS_STRING;

static void GenBStackElems (StateS state)
{
	if (IsSimpleState (state)){
		if (state.state_kind == OnB)
			PutCOutFile (BElems [(int) state.state_object]);			
	} else {
		int arity;
		States argstates;
		
		switch (state.state_type){
			case TupleState:
				argstates = state.state_tuple_arguments;
				break;
			case RecordState:
				argstates = state.state_record_arguments;
				break;
			case ArrayState:
				return;
			default:
				error_in_function ("GenBStackElems");
				return;
		}
		for (arity=0; arity < state.state_arity; ++arity)
			GenBStackElems (argstates[arity]);
	}
}

static void GenABStackElems (StateS state)
{
	if (IsSimpleState (state)){
		if (state.state_kind == OnB)
			PutCOutFile (BElems [(int) state.state_object]);
		else
			PutCOutFile ('a');
	} else {
		int arity;
		States argstates;
		
		switch (state.state_type){
			case TupleState:
				argstates = state.state_tuple_arguments;			
				PutCOutFile ('(');
				if (state.state_arity>0){
					GenABStackElems (argstates[0]);
					for (arity=1; arity < state.state_arity; arity++){
						PutCOutFile (',');
						GenABStackElems (argstates[arity]);
					}
				}
				PutCOutFile (')');
				break;
			case RecordState:
				argstates = state.state_record_arguments;
				PutCOutFile ('(');
				for (arity=0; arity < state.state_arity; arity++)
					GenABStackElems (argstates[arity]);
				PutCOutFile (')');
				return;
			case ArrayState:
				PutCOutFile ('a');
				return;
			default:
				error_in_function ("GenABStackElems");
				return;
		}
	}
}

static void GenABStackElemsForRecordDesc (StateS state)
{
	if (IsSimpleState (state)){
		if (state.state_kind == OnB)
			PutCOutFile (BElems [(int) state.state_object]);
		else
			PutCOutFile ('a');
	} else {
		int arity;
		States argstates;
		
		switch (state.state_type){
			case TupleState:
				argstates = state.state_tuple_arguments;			
				PutCOutFile ('(');
				if (state.state_arity>0){
					GenABStackElemsForRecordDesc (argstates[0]);
					for (arity=1; arity < state.state_arity; ++arity){
						PutCOutFile (',');
						GenABStackElemsForRecordDesc (argstates[arity]);
					}
				}
				PutCOutFile (')');
				return;
			case RecordState:
				argstates = state.state_record_arguments;
				PutCOutFile ('{');
				for (arity=0; arity < state.state_arity; ++arity)
					GenABStackElemsForRecordDesc (argstates[arity]);
				PutCOutFile ('}');
				return;
			case ArrayState:
				PutCOutFile ('a');
				return;
			default:
				error_in_function ("GenABStackElemsForRecordDesc");
		}
	}
}

static void GenABStackElemsOfRecord (StateS state)
{
	if (state.state_type==RecordState){
		int arity;
		States argstates;

		argstates = state.state_record_arguments;
		for (arity=0; arity < state.state_arity; ++arity)
			GenABStackElemsForRecordDesc (argstates[arity]);
	} else
		GenABStackElemsForRecordDesc (state);
}

static int AddSizeOfStatesAndImportRecords (int arity, States states, int *asize, int *bsize);

static int AddSizeOfStateAndImportRecords (StateS state, int *asize, int *bsize)
{
	if (IsSimpleState (state)){
		if (state.state_kind == OnB)
			*bsize += ObjectSizes [state.state_object];
		else if (state.state_kind != Undefined)
			*asize += SizeOfAStackElem;
		return 0;
	} else {
		switch (state.state_type){
			case RecordState:
			{
				SymbDef record_sdef;

				record_sdef = state.state_record_symbol;
				if (record_sdef->sdef_exported || record_sdef->sdef_module!=CurrentModule || ExportLocalLabels){
					if ((record_sdef->sdef_mark & SDEF_RECORD_R_LABEL_IMPORTED_MASK)!=0){
						record_sdef->sdef_mark |= SDEF_USED_STRICTLY_MASK;
					} else {
						record_sdef->sdef_mark |= SDEF_USED_STRICTLY_MASK;
						record_sdef->sdef_mark |= SDEF_USED_STRICTLY_MASK | SDEF_RECORD_R_LABEL_IMPORTED_MASK;
						GenImpRecordDesc (record_sdef->sdef_module,record_sdef->sdef_name);
					}
				}

				(void) AddSizeOfStatesAndImportRecords (state.state_arity, state.state_record_arguments, asize, bsize);
				return 1;
			}
			case TupleState:
				return AddSizeOfStatesAndImportRecords (state.state_arity, state.state_tuple_arguments, asize, bsize);
			case ArrayState:
				*asize += SizeOfAStackElem;
				return 0;
		}
	}
	return 0;
}

static int AddSizeOfStatesAndImportRecords (int arity, States states, int *asize, int *bsize)
{
	int has_unboxed_record;
	
	has_unboxed_record=0;
	for (; arity; arity--)
		has_unboxed_record |= AddSizeOfStateAndImportRecords (states [arity-1], asize, bsize);
	return has_unboxed_record;
}

static void GenUnboxedRecordLabelsReversed (StateS state)
{
	if (!IsSimpleState (state)){
		int arity;
		States argstates;
		
		switch (state.state_type){
			case TupleState:
				argstates = state.state_tuple_arguments;			
				for (arity=state.state_arity-1; arity>=0; --arity)
					GenUnboxedRecordLabelsReversed (argstates[arity]);
				return;
			case RecordState:
			{
				SymbDef record_sdef;

				argstates = state.state_record_arguments;
				for (arity=state.state_arity-1; arity>=0 ; --arity)
					GenUnboxedRecordLabelsReversed (argstates[arity]);

				record_sdef = state.state_record_symbol;
				if (!record_sdef->sdef_exported && record_sdef->sdef_module==CurrentModule && !ExportLocalLabels){
					if (DoDebug)
						FPrintF (OutFile, R_PREFIX "%s ",record_sdef->sdef_name);
					else
						FPrintF (OutFile, R_PREFIX "%u ",record_sdef->sdef_number);
				} else
					FPrintF (OutFile, "e_%s_" R_PREFIX "%s ",record_sdef->sdef_module,record_sdef->sdef_name);
				return;
			}
			case ArrayState:
				return;
			default:
				error_in_function ("GenUnboxedRecordLabelsReversed");
				return;
		}
	}
}

static void GenUnboxedRecordLabelsReversedForRecord (StateS state)
{
	if (state.state_type==RecordState){
		int arity;
		States argstates;

		argstates = state.state_record_arguments;
		for (arity=state.state_arity-1; arity>=0; --arity)
			GenUnboxedRecordLabelsReversed (argstates[arity]);
	} else
		GenUnboxedRecordLabelsReversed (state);
}

void GenDStackLayout (int asize,int bsize,Args fun_args)
{
	if (DoStackLayout){
		put_directiveb (d);
		if (bsize > 0){
			put_arguments_nn_b (asize,bsize);
			PutCOutFile (' ');

			while (fun_args!=NULL){
				GenBStackElems (fun_args->arg_state);
				fun_args=fun_args->arg_next;
			}
		} else
			put_arguments_nn_b (asize,0);
	}
}

void GenOStackLayout (int asize,int bsize,Args fun_args)
{
	if (DoStackLayout){
		put_directiveb (o);
		if (bsize > 0){
			put_arguments_nn_b (asize,bsize);
			PutCOutFile (' ');

			while (fun_args!=NULL){
				GenBStackElems (fun_args->arg_state);
				fun_args=fun_args->arg_next;
			}
		} else
			put_arguments_nn_b (asize,0);
	}
}

static void GenABCInstructions (Instructions ilist)
{
	for (; ilist; ilist = ilist->instr_next){
		char *instruction_name;
		
		instruction_name=ilist->instr_this;
		
		PutCOutFile ('\n');
		if (instruction_name[0]==':')
			PutSOutFile (&instruction_name[1]);
		else {
			if (instruction_name[0]!='.')
				PutCOutFile ('\t');
			PutSOutFile (instruction_name);
		}
	}
}

static void CallFunction2 (Label label, SymbDef def, Bool isjsr, StateS root_state, Args fun_args, int arity)
{
	int ain,aout,bin,bout;
	Args arg;
	
	ain=0;
	bin=0;
	
	if (fun_args != NULL){
		for (arg = fun_args; arg; arg = arg -> arg_next)
			AddSizeOfState  (arg -> arg_state, &ain, &bin);
	} else
		ain = arity;
	DetermineSizeOfState (root_state, &aout, &bout);

	if (IsSimpleState (root_state) && (root_state.state_kind!=OnB && root_state.state_kind!=StrictRedirection))
		ain++;

	if (label->lab_mod && label->lab_mod==CurrentModule)
		label->lab_mod = NULL;

	label->lab_pref = s_pref;

	if (def->sdef_kind==IMPRULE){
		if ((def->sdef_mark & SDEF_INLINE_IS_CONSTRUCTOR)!=0){
			generate_is_constructor (def->sdef_rule);
			if (!isjsr)
				GenRtn (aout, bout, root_state);
			return;
		} else if (IsInlineFromCurrentModule (def)){
			Instructions instruction, last, first, next;

			instruction=def->sdef_rule->rule_alts->alt_rhs_code->co_instr;
			instruction=instruction->instr_next;
			first=instruction;

			last=NULL;
			for (;(next=instruction->instr_next)!=NULL;instruction=next)
				last=instruction;

			last->instr_next=NULL;
			GenInstructions (first);
			last->instr_next=instruction;

			if (!isjsr)
				GenRtn (aout, bout, root_state);
			return;
		}
	} else if ((def->sdef_mark & SDEF_DEFRULE_ABC_CODE)!=0 && (def->sdef_kind==SYSRULE || def->sdef_kind==DEFRULE)){
		GenABCInstructions (def->sdef_abc_code);
		if (!isjsr)
			GenRtn (aout, bout, root_state);
		return;
	}

	GenDStackLayout (ain, bin, fun_args);
	if (isjsr){
		GenJsr (label);
		GenOStackLayoutOfState (aout, bout, root_state);
	} else
		GenJmp (label);
}

void CallFunction (Label label, SymbDef def, Bool isjsr, Node root)
{
	if (def->sdef_arfun<NoArrayFun)
		CallArrayFunction (def,isjsr,&root->node_state);
	else
		CallFunction2 (label, def, isjsr, root->node_state, root->node_arguments, root->node_arity);
}

void CallFunction1 (Label label, SymbDef def, StateS root_state, Args fun_args, int arity)
{
	CallFunction2 (label, def, True, root_state, fun_args, arity);
}

static void GenArraySize (Label elemdesc, int asize, int bsize)
{
	put_instruction_ (Ipush_arraysize);
	GenLabel (elemdesc);
	put_arguments_nn_b (asize, bsize);
}

static void GenArraySelect (Label elemdesc, int asize, int bsize)
{
	put_instruction_ (Iselect);
	GenLabel (elemdesc);
	put_arguments_nn_b (asize, bsize);
}

static void GenArrayUpdate (Label elemdesc, int asize, int bsize)
{
	put_instruction_ (Iupdate);
	GenLabel (elemdesc);
	put_arguments_nn_b (asize, bsize);	
}

static void GenArrayReplace (Label elemdesc, int asize, int bsize)
{
	put_instruction_ (Ireplace);
	GenLabel (elemdesc);
	put_arguments_nn_b (asize, bsize);
}

#if CLEAN2
static int CaseFailNumber;
#endif

void CallArrayFunction (SymbDef array_def,Bool is_jsr,StateP node_state_p)
{
	LabDef elem_desc;
	int asize, bsize;
	Bool elem_is_lazy;
	StateS array_state;
	ArrayFunKind fkind;
	StateP function_state_p;
	
	fkind = (ArrayFunKind)array_def->sdef_arfun;