/*
(Concurrent) Clean Compiler: ABC instructions
Authors: Sjaak Smetsers & John van Groningen
*/
#pragma segment instructions
#include "compiledefines.h"
#include "comsupport.h"
#include "system.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 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,"");
}
#ifdef _STANDALONE_
/* 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_DoVerbose 6
*/
#define N_DoWarning 7
#define N_System 8
static void ConvertOptionsToString (CompilerOptions options,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_DoVerbose] = DoVerbose ? '1' : '0';
*/
optstring[N_DoWarning] = DoWarning ? '1' : '0';
optstring[N_System] = '0';
optstring[NR_OPTIONS] = '\0';
}
#else
# define N_System 8
# include "cginterface.t"
# include "project.h"
#endif
#define D_PREFIX "d"
#define N_PREFIX "n"
#define L_PREFIX "l"
#define EA_PREFIX "ea"
#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, abcFile, "w");
if (OutFile!=NULL){
#if defined (THINK_C) || defined (POWER)
setvbuf ((FILE*) OutFile, NULL, _IOFBF, 8192);
#endif
OpenedFile = OutFile;
ABCFileName = fname;
return True;
} else
return False;
}
void WriteLastNewlineToABCFile (void)
{
FPutC ('\n',OutFile);
}
void CloseABCFile (char *fname)
{
if (OutFile){
#ifdef THINK_C
int file_io_error;
file_io_error=ferror (OutFile);
#endif
if (FClose (OutFile) != 0
#ifdef THINK_C
|| file_io_error
#endif
){
CompilerError = True;
CurrentLine = 0;
StaticMessage (True, "<open file>", "Write error (disk full?)");
}
if (CompilerError)
FDelete (fname, abcFile);
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 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_ident->ident_name);
else if (DoDebug){
if (def->sdef_kind==IMPRULE)
FPrintF (OutFile, "%s%s.%u",label->lab_pref,def->sdef_ident->ident_name,def->sdef_number);
else
FPrintF (OutFile, "%s%s",label->lab_pref,def->sdef_ident->ident_name);
} else if (def->sdef_number==0)
FPrintF (OutFile, "%s%s",label->lab_pref,def->sdef_ident->ident_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 {
FPutS (label->lab_pref,OutFile);
FPutS (label->lab_name,OutFile);
}
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_ident->ident_name);
else if (ExportLocalLabels){
if (def->sdef_kind==IMPRULE)
FPrintF (OutFile,"e_%s_%s%s.%u",CurrentModule,label->lab_pref,def->sdef_ident->ident_name,def->sdef_number);
else
FPrintF (OutFile,"e_%s_%s%s",CurrentModule,label->lab_pref,def->sdef_ident->ident_name);
} else if (DoDebug){
if (def->sdef_kind==IMPRULE)
FPrintF (OutFile, "%s%s.%u",label->lab_pref,def->sdef_ident->ident_name,def->sdef_number);
else
FPrintF (OutFile, "%s%s",label->lab_pref,def->sdef_ident->ident_name);
} else if (def->sdef_number==0)
FPrintF (OutFile, "%s%s",label->lab_pref,def->sdef_ident->ident_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 {
FPutS (label->lab_pref,OutFile);
FPutS (label->lab_name,OutFile);
}
if (label->lab_post!=0)
FPrintF (OutFile,".%u",label->lab_post);
}
static void GenGetWL (int offset)
{
FPrintF (OutFile, "\n\tgetWL %d", offset);
}
static void GenPutWL (int offset)
{
FPrintF (OutFile, "\n\tputWL %d", offset);
}
static void GenRelease (void)
{
FPutS ("\n\trelease", OutFile);
}
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;
}
}
}
#if !BINARY_ABC
#define put_instructionb(a) put_instruction(I##a)
#define put_instruction_b(a) put_instruction_(I##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_arguments_n_b(n1) FPrintF (OutFile,"%d",(n1))
#define put_arguments_nn_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_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))
#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_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)){
FPutC (128+(n & 127),OutFile);
n=n>>7;
}
FPutC (n+64,OutFile);
}
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)
FPrintF (OutFile,"%s",(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_arguments_n_b (long n1)
{
if (DoDebug)
FPrintF (OutFile,"%d",(n1));
else
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_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_arguments_n__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 {
FPutC (' ',OutFile);
put_n (n1);
}
}
static void put_arguments__n__b (long n1)
{
if (DoDebug)
FPrintF (OutFile," %d ",(n1));
else {
FPutC (' ',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 {
FPutC (' ',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,
Cn
};
#endif
#define IbuildB "buildB"
#define IbuildC "buildC"
#define IbuildI "buildI"
#define IbuildR "buildR"
#define IbuildS "buildS"
#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 IfillS "fillS"
#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 IeqS_a "eqS_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 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 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 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 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 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 Ihalt "halt"
#define Itestcaf "testcaf"
#define Ipushcaf "pushcaf"
#define Ifillcaf "fillcaf"
#define Iin "in"
#define Iout "out"
static void put_instruction (char *instruction)
{
FPutC ('\n',OutFile);
FPutC ('\t',OutFile);
FPutS (instruction,OutFile);
}
static void put_instruction_ (char *instruction)
{
FPutC ('\n',OutFile);
FPutC ('\t',OutFile);
FPutS (instruction,OutFile);
FPutC (' ',OutFile);
}
static void put_instruction_code (int instruction_code)
{
FPutC (instruction_code,OutFile);
}
#define Dkeep "keep"
#define Dd "d"
#define Do "o"
#define Dimpdesc "impdesc"
#define Dimplab "implab"
#define Dexport "export"
#define Dn "n"
#define Dnu "nu"
#define Dn_string "n_string"
#define Ddesc "desc"
#define Ddescn "descn"
#define Ddescexp "descexp"
#define Drecord "record"
#define Dmodule "module"
#define Ddepend "depend"
#define Dcomp "comp"
#define Dcode "code"
#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)
{
FPutC ('\n',OutFile);
FPutC ('.',OutFile);
FPutS (directive,OutFile);
}
static void put_directive_ (char *directive)
{
FPutC ('\n',OutFile);
FPutC ('.',OutFile);
FPutS (directive,OutFile);
FPutC (' ',OutFile);
}
static void put_first_directive_ (char *directive)
{
FPutC ('.',OutFile);
FPutS (directive,OutFile);
FPutC (' ',OutFile);
}
void BuildBasicFromB (ObjectKind kind,int b_offset)
{
switch (kind){
case IntObj:
case ProcIdObj:
case RedIdObj:
put_instruction_b (buildI_b); break;
case BoolObj:
put_instruction_b (buildB_b); break;
case CharObj:
put_instruction_b (buildC_b); break;
case RealObj:
put_instruction_b (buildR_b); break;
case FileObj:
put_instruction_b (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_instruction_b (fillI_b); break;
case BoolObj:
put_instruction_b (fillB_b); break;
case CharObj:
put_instruction_b (fillC_b); break;
case RealObj:
put_instruction_b (fillR_b); break;
case FileObj:
put_instruction_b (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_instruction_b (buildI);
put_arguments_i_b (val.val_int);
break;
case BoolObj:
put_instruction_ (IbuildB);
if (val.val_bool)
FPrintF (OutFile, "TRUE");
else
FPrintF (OutFile, "FALSE");
break;
case CharObj:
put_instruction_ (IbuildC);
FPrintF (OutFile, "%s", val.val_char);
break;
case RealObj:
put_instruction_ (IbuildR);
FPrintF (OutFile, "%s", val.val_real);
break;
case StringObj:
put_instruction_ (IbuildS);
FPrintF (OutFile, "%s", val.val_string);
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_instruction_b (fillI);
put_arguments_in_b (val.val_int,offset);
break;
case BoolObj:
put_instruction_ (IfillB);
if (val.val_bool)
FPrintF (OutFile, "TRUE %d", offset);
else
FPrintF (OutFile, "FALSE %d", offset);
break;
case CharObj:
put_instruction_ (IfillC);
FPrintF (OutFile, "%s %d", val.val_char, offset);
break;
case RealObj:
put_instruction_ (IfillR);
FPrintF (OutFile, "%s %d", val.val_real, offset);
break;
case StringObj:
put_instruction_ (IfillS);
FPrintF (OutFile, "%s %d", val.val_string, offset);
break;
default:
error_in_function ("FillBasic");
return;
}
TreatWaitListAfterFill (offset, fkind);
}
void IsBasic (ObjectKind obj, SymbValue val, int offset)
{
switch (obj){
case IntObj:
put_instruction_b (eqI_a);
put_arguments_in_b (val.val_int,offset);
break;
case BoolObj:
put_instruction_ (IeqB_a);
if (val.val_bool)
FPrintF (OutFile, "TRUE %d", offset);
else
FPrintF (OutFile, "FALSE %d", offset);
break;
case CharObj:
put_instruction_ (IeqC_a);
FPrintF (OutFile, "%s %d", val.val_char, offset); break;
case RealObj:
put_instruction_ (IeqR_a);
FPrintF (OutFile, "%s %d", val.val_real, offset); break;
case StringObj:
put_instruction_ (IeqS_a);
FPrintF (OutFile, "%s %d", val.val_string, offset); break;
default:
error_in_function ("IsBasic");
return;
}
}
void IsString (SymbValue val)
{
put_instruction_ (IeqAC_a);
FPrintF (OutFile, "%s",val.val_string);
}
void PushBasic (ObjectKind obj, SymbValue val)
{
switch (obj){
case IntObj:
put_instruction_b (pushI);
put_arguments_i_b (val.val_int);
break;
case BoolObj:
put_instruction_ (IpushB);
if (val.val_bool)
FPutS ("TRUE", OutFile);
else
FPutS ("FALSE", OutFile);
break;
case CharObj:
put_instruction_ (IpushC);
FPrintF (OutFile, "%s", val.val_char); break;
case RealObj:
put_instruction_ (IpushR);
FPrintF (OutFile, "%s", val.val_real); break;
default:
error_in_function ("PushBasic");
return;
}
}
void GenPushReducerId (int i)
{
put_instruction_b (pushI);
put_arguments_n_b (i);
}
void GenPushArgNr (int argnr)
{
put_instruction_b (pushI);
put_arguments_n_b (argnr);
}
void EqBasic (ObjectKind obj, SymbValue val, int offset)
{
switch (obj){
case IntObj:
put_instruction_b (eqI_b);
put_arguments_in_b (val.val_int,offset);
break;
case BoolObj:
put_instruction_ (IeqB_b);
if (val.val_bool)
FPrintF (OutFile, "TRUE %d", offset);
else
FPrintF (OutFile, "FALSE %d", offset);
break;
case CharObj:
put_instruction_ (IeqC_b);
FPrintF (OutFile, "%s %d", val.val_char, offset); break;
case RealObj:
put_instruction_ (IeqR_b);
FPrintF (OutFile, "%s %d", val.val_real, offset); break;
default:
error_in_function ("EqBasic");
return;
}
}
void GenNotB (void)
{
put_instruction (InotB);
}
void PushBasicFromAOnB (ObjectKind kind,int offset)
{
switch (kind){
case IntObj:
case ProcIdObj:
case RedIdObj:
put_instruction_b (pushI_a);
break;
case BoolObj:
put_instruction_b (pushB_a);
break;
case CharObj:
put_instruction_b (pushC_a);
break;
case RealObj:
put_instruction_b (pushR_a);
break;
case FileObj:
put_instruction_b (pushF_a);
break;
default:
error_in_function ("PushBasicFromAOnB");
return;
}
put_arguments_n_b (offset);
}
void GenPushD_a (int a_offset)
{
put_instruction_ (IpushD_a);
FPrintF (OutFile,"%d",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)
FPutC (BElems [(int) state.state_object], OutFile);
} 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)
FPutC (BElems [(int) state.state_object], OutFile);
else
FPutC ('a', OutFile);
} 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:
FPutC ('a', OutFile);
return;
default:
error_in_function ("GenABStackElems");
return;
}
for (arity=0; arity < state.state_arity; arity++)
GenABStackElems (argstates[arity]);
}
}
void GenDStackLayout (int asize,int bsize,Args fun_args)
{
if (DoStackLayout){
put_directive_b (d);
if (bsize > 0){
put_arguments_nn__b (asize,bsize);
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_directive_b (o);
if (bsize > 0){
put_arguments_nn__b (asize,bsize);
while (fun_args!=NULL){
GenBStackElems (fun_args->arg_state);
fun_args=fun_args->arg_next;
}
} else
put_arguments_nn_b (asize,0);
}
}
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==SYSRULE){
char *instr;
instr= def->sdef_ident->ident_instructions;
if (instr && *instr!='\0'){
char *tail;
for (; *instr != '\0'; instr = tail){
for (tail = instr; *tail != '\n'; tail++)
;
*tail = '\0';
FPrintF (OutFile, "\n%s", instr);
*tail++ = '\n';
}
if (!isjsr)
GenRtn (aout, bout, root_state);
} else {
if (def->sdef_ident->ident_environ && instr==NULL)
{ char *previous_module = CurrentModule;
char *previous_ext = CurrentExt;
CurrentModule = def->sdef_module;
CurrentExt = GetFileExtension (abcFile);
StaticMessage (False, "%D", "no inline code for this rule", def);
CurrentModule = previous_module;
CurrentExt = previous_ext;
def->sdef_ident->ident_environ = (char *) NIL;
}
GenDStackLayout (ain, bin, fun_args);
if (isjsr){
GenJsr (label);
GenOStackLayoutOfState (aout, bout, root_state);
} else
GenJmp (label);
}
} else if (def->sdef_kind==IMPRULE && 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);
} else {
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);
}
static void GenArraySize (Label elemdesc, int asize, int bsize)
{
put_instruction_ (Ipush_arraysize);
GenLabel (elemdesc);
FPrintF (OutFile, " %d %d", asize, bsize);
}
static void GenArraySelect (Label elemdesc, int asize, int bsize)
{
put_instruction_ (Iselect);
GenLabel (elemdesc);
FPrintF (OutFile, " %d %d", asize, bsize);
}
static void GenArrayUpdate (Label elemdesc, int asize, int bsize)
{
put_instruction_ (Iupdate);
GenLabel (elemdesc);
FPrintF (OutFile, " %d %d", asize, bsize);
}
static void GenArrayReplace (Label elemdesc, int asize, int bsize)
{
put_instruction_ (Ireplace);
GenLabel (elemdesc);
FPrintF (OutFile, " %d %d", asize, bsize);
}
extern Symbol UnboxedArrayFunctionSymbols [];
static Label ApplyLabel;
static StateS ApplyState;
extern SymbDef ApplyDef; /* from codegen2.c */
static void ApplyOperatorToArrayAndIndex (Bool is_jsr)
{
GenPushA (0);
GenCreate (-1);
GenFillArray (3, 0, NormalFill);
GenUpdateA (0, 2);
BuildBasicFromB (IntObj,0);
GenPopB (SizeOfInt);
GenUpdateA (0, 4);
GenPopA (2);
CallFunction2 (ApplyLabel, ApplyDef, True, ApplyState, NULL, 2);
CallFunction2 (ApplyLabel, ApplyDef, is_jsr, ApplyState, NULL, 2);
}
static void ApplyOperatorToArrayElem (int asize, int bsize, ObjectKind kind)
{
if (asize==0){
GenPushA (0);
BuildBasicFromB (kind,0);
GenUpdateA (0, 2);
GenPopB (bsize);
GenPopA (1);
}
CallFunction2 (ApplyLabel, ApplyDef, True, ApplyState, NULL, 2);
}
static void UnpackResultTuple (int asize,int bsize,ObjectKind kind)
{
GenReplArgs (2, 2);
if (asize==0){
PushBasicFromAOnB (kind, 0);
GenPopA (1);
}
GenPushArray (asize);
GenUpdateA (0,1+asize);
GenPopA (1);
}
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;
/* RWS ...
function_state_p = array_def->sdef_rule_type->rule_type_state_p;
*/
switch (array_def->sdef_kind)
{
case DEFRULE:
case SYSRULE:
function_state_p = array_def->sdef_rule_type->rule_type_state_p;
break;
case IMPRULE:
function_state_p = array_def->sdef_rule->rule_state_p;
break;
default:
error_in_function ("CallArrayFunction");
break;
}
/* RWS */
if (function_state_p[0].state_type==SimpleState && function_state_p[0].state_object==UnknownObj){
StateS elem_state;
switch (fkind){
case CreateArrayFun:
case _CreateArrayFun:
array_state=function_state_p[-1];
break;
case _UnqArraySelectNextFun:
case _UnqArraySelectLastFun:
case _ArrayUpdateFun:
if (function_state_p[1].state_type==TupleState)
array_state=function_state_p[1].state_tuple_arguments[0];
else
error_in_function ("CallArrayFunction");
break;
default:
array_state=function_state_p[1];
}
elem_state = array_state.state_array_arguments [0];
if (array_state.state_type==ArrayState && (array_state.state_mark & STATE_UNBOXED_ARRAY_MASK)){
if (ApplyLabel == NULL){
ApplyLabel = CompAllocType (LabDef);
ConvertSymbolToLabel (ApplyLabel, ApplyDef);
}
switch (fkind){
case CreateArrayFun:
case _CreateArrayFun:
GenPushA (0);
BuildBasicFromB (IntObj,0);
GenPopB (SizeOfInt);
GenUpdateA (0, 2);
GenPopA (1);
CallFunction2 (ApplyLabel, ApplyDef, True, ApplyState, NULL, 2);
if (fkind!=_CreateArrayFun)
CallFunction2 (ApplyLabel, ApplyDef, True, ApplyState, NULL, 2);
GenPushArray (0);
GenUpdateA (0, 1);
GenPopA (1);
break;
case ArraySelectFun:
if (elem_state.state_kind==StrictOnA)
ApplyOperatorToArrayAndIndex (is_jsr);
else {
ApplyOperatorToArrayAndIndex (True);
PushBasicFromAOnB (elem_state.state_object, 0);
GenPopA (1);
}
break;
case UnqArraySelectFun:
#ifdef OBSERVE_ARRAY_SELECTS_IN_PATTERN
DetermineSizeOfState (elem_state,&asize,&bsize);
ApplyOperatorToArrayAndIndex (True);
if (node_state_p->state_type==TupleState
&& node_state_p->state_tuple_arguments[1].state_type==SimpleState
&& node_state_p->state_tuple_arguments[1].state_kind==Undefined)
{
GenReplArg (2,1);
if (asize==0){
PushBasicFromAOnB (elem_state.state_object,0);
GenPopA (1);
}
} else
UnpackResultTuple (asize,bsize,elem_state.state_object);
break;
#endif
case _UnqArraySelectFun:
DetermineSizeOfState (elem_state,&asize,&bsize);
ApplyOperatorToArrayAndIndex (True);
UnpackResultTuple (asize, bsize, elem_state.state_object);
break;
case _UnqArraySelectNextFun:
case _UnqArraySelectLastFun:
DetermineSizeOfState (elem_state,&asize,&bsize);
GenCreate (-1);
GenFillArray (3, 0, NormalFill);
GenCreate (-1);
GenFillArray (3, 0, NormalFill);
GenBuildh (&tuple_lab,2);
GenUpdateA (0, 2);
BuildBasicFromB (IntObj,0);
GenPopB (SizeOfInt);
GenUpdateA (0, 4);
GenPopA (2);
CallFunction2 (ApplyLabel, ApplyDef, True, ApplyState, NULL, 2);
CallFunction2 (ApplyLabel, ApplyDef, True, ApplyState, NULL, 2);
UnpackResultTuple (asize, bsize, elem_state.state_object);
break;
case _ArrayUpdateFun:
DetermineSizeOfState (elem_state,&asize,&bsize);
GenCreate (-1);
GenFillArray (3, 0, NormalFill);
GenCreate (-1);
GenFillArray (3, 0, NormalFill);
GenBuildh (&tuple_lab,2);
GenUpdateA (0, 2);
BuildBasicFromB (IntObj,0);
GenPopB (SizeOfInt);
GenUpdateA (0, 4);
GenPopA (2);
CallFunction2 (ApplyLabel, ApplyDef, True, ApplyState, NULL, 2);
CallFunction2 (ApplyLabel, ApplyDef, True, ApplyState, NULL, 2);
ApplyOperatorToArrayElem (asize, bsize, elem_state.state_object);
GenPushArray (0);
GenUpdateA (0, 1);
GenPopA (1);
break;
case ArrayUpdateFun:
DetermineSizeOfState (elem_state,&asize,&bsize);
ApplyOperatorToArrayAndIndex (True);
ApplyOperatorToArrayElem (asize,bsize,elem_state.state_object);
GenPushArray (0);
GenUpdateA (0, 1);
GenPopA (1);
break;
case ArrayReplaceFun:
DetermineSizeOfState (elem_state,&asize,&bsize);
ApplyOperatorToArrayAndIndex (True);
ApplyOperatorToArrayElem (asize,bsize,elem_state.state_object);
UnpackResultTuple (asize,bsize,elem_state.state_object);
break;
case ArraySizeFun:
GenCreate (-1);
GenFillArray (2, 0, NormalFill);
GenUpdateA (0, 2);
GenPopA (1);
CallFunction2 (ApplyLabel, ApplyDef, True, ApplyState, NULL, 2);
PushBasicFromAOnB (IntObj, 0);
GenPopA (1);
break;
case UnqArraySizeFun:
GenCreate (-1);
GenFillArray (2, 0, NormalFill);
GenUpdateA (0, 2);
GenPopA (1);
CallFunction2 (ApplyLabel, ApplyDef, True, ApplyState, NULL, 2);
UnpackResultTuple (0, SizeOfInt, IntObj);
break;
}
if (! is_jsr){
DetermineSizeOfState (function_state_p[-1], & asize, & bsize);
GenRtn (asize,bsize,function_state_p[-1]);
}
return;
}
else
{ GenPopA (1);
elem_desc = BasicDescriptors [UnknownObj];
asize = 1;
bsize = 0;
elem_is_lazy = elem_state.state_type==SimpleState && elem_state.state_kind==OnA;
}
} else {
switch (fkind){
case CreateArrayFun:
case _CreateArrayFun:
array_state = function_state_p[-1];
break;
case _UnqArraySelectNextFun:
case _UnqArraySelectLastFun:
case _ArrayUpdateFun:
if (function_state_p[0].state_type==TupleState)
array_state=function_state_p[0].state_tuple_arguments[0];
else
error_in_function ("CallArrayFunction");
break;
default:
array_state = function_state_p[0];
}
if (array_state.state_type == ArrayState){
StateS elem_state = array_state.state_array_arguments [0];
DetermineArrayElemDescr (elem_state, & elem_desc);
DetermineSizeOfState (elem_state, & asize, & bsize);
elem_is_lazy = elem_state.state_type==SimpleState && elem_state.state_kind==OnA;
} else
error_in_function ("CallArrayFunction");
}
switch (fkind){
case CreateArrayFun:
put_instruction_ ("create_array");
GenLabel (&elem_desc);
FPrintF (OutFile," %d %d",asize,bsize);
break;
case _CreateArrayFun:
put_instruction_ ("create_array_");
GenLabel (&elem_desc);
FPrintF (OutFile," %d %d",asize,bsize);
break;
case ArraySelectFun:
GenArraySelect (&elem_desc,asize,bsize);
if (elem_is_lazy){
if (is_jsr)
GenJsrEval (0);
else {
GenJmpEval ();
return;
}
}
break;
case UnqArraySelectFun:
#ifdef OBSERVE_ARRAY_SELECTS_IN_PATTERN
if (! (node_state_p->state_type==TupleState
&& node_state_p->state_tuple_arguments[1].state_type==SimpleState
&& node_state_p->state_tuple_arguments[1].state_kind==Undefined))
{
GenPushA (0);
}
GenArraySelect (&elem_desc,asize,bsize);
break;
#endif
case _UnqArraySelectFun:
GenPushA (0);
GenArraySelect (&elem_desc,asize,bsize);
break;
case _UnqArraySelectNextFun:
case _UnqArraySelectLastFun:
{
int record_or_array_a_size,record_or_array_b_size;
if (node_state_p->state_type!=TupleState)
error_in_function ("CallArrayFunction");
DetermineSizeOfState (node_state_p->state_tuple_arguments[1],&record_or_array_a_size,&record_or_array_b_size);
if (record_or_array_b_size>0){
int i;
GenPushB (record_or_array_b_size);
for (i=record_or_array_b_size; i>=0; --i)
GenUpdateB (i,i+1);
GenPopB (1);
}
GenArraySelect (&elem_desc,asize,bsize);
break;
}
case _ArrayUpdateFun:
{
int i,result_a_size,result_b_size;
DetermineSizeOfState (*node_state_p,&result_a_size,&result_b_size);
if (asize!=0){
for (i=0; i<asize; ++i)
GenPushA (result_a_size+asize);
for (i=result_a_size-1; i>=0; --i)
GenUpdateA (i+asize+1,i+asize+1+asize);
for (i=asize-1; i>=0; --i)
GenUpdateA (i,i+1+asize);
GenPopA (asize);
}
if (result_b_size!=0){
int b_size_with_index;
b_size_with_index=bsize+1;
for (i=0; i<b_size_with_index; ++i)
GenPushB (result_b_size+b_size_with_index-1);
for (i=result_b_size-1; i>=0; --i)
GenUpdateB (i+b_size_with_index,i+b_size_with_index+b_size_with_index);
for (i=b_size_with_index-1; i>=0; --i)
GenUpdateB (i,i+b_size_with_index);
GenPopB (b_size_with_index);
}
GenArrayUpdate (&elem_desc,asize,bsize);
for (i=0; i<result_a_size; ++i)
GenKeep (0,i+1);
GenPopA (1);
break;
}
case ArrayUpdateFun:
GenArrayUpdate (& elem_desc, asize, bsize);
break;
case ArrayReplaceFun:
GenArrayReplace (& elem_desc, asize, bsize);
break;
case ArraySizeFun:
GenArraySize (& elem_desc, asize, bsize);
break;
case UnqArraySizeFun:
GenPushA (0);
GenArraySize (& elem_desc, asize, bsize);
break;
}
if (! is_jsr){
DetermineSizeOfState (*node_state_p,&asize,&bsize);
GenRtn (asize,bsize,*node_state_p);
}
}
void GenNewContext (Label contlab, int offset)
{
FPrintF (OutFile, "\n\tset_entry ");
GenLabel (contlab);
FPrintF (OutFile, " %d", offset);
}
void GenSetDefer (int offset)
{
FPrintF (OutFile, "\n\tset_defer %d", offset);
}
void GenReplArgs (int arity, int nrargs)
{
if (nrargs > 0){
put_instruction_b (repl_args);
put_arguments_nn_b (arity,nrargs);
} else
GenPopA (1);
}
void GenReplArg (int arity, int argnr)
{
put_instruction_b (repl_arg);
put_arguments_nn_b (arity,argnr);
}
void GenPushArgs (int offset, int arity, int nrargs)
{
if (nrargs > 0){
put_instruction_b (push_args);
put_arguments_nnn_b (offset,arity,nrargs);
}
}
void GenPushArgsU (int offset, int arity, int nrargs)
{
if (nrargs > 0){
put_instruction_b (push_args_u);
put_arguments_nnn_b (offset,arity,nrargs);
}
}
void GenPushArg (int offset, int arity, int argnr)
{
put_instruction_b (push_arg);
put_arguments_nnn_b (offset,arity,argnr);
}
void GenPushRArgs (int offset, int nr_a_args, int nr_b_args)
{
if (nr_a_args + nr_b_args > 0){
put_instruction_b (push_r_args);
put_arguments_nnn_b (offset,nr_a_args,nr_b_args);
}
}
void GenPushRArgsU (int offset,int n_a_args,int n_b_args)
{
if (n_a_args + n_b_args > 0){
put_instruction_b (push_r_args_u);
put_arguments_nnn_b (offset,n_a_args,n_b_args);
}
}
void GenPushRArgA (int offset, int tot_nr_a_args, int tot_nr_b_args, int args_nr, int nr_a_args)
{
if (nr_a_args > 0){
put_instruction_b (push_r_args_a);
put_arguments_nnnnn_b (offset,tot_nr_a_args,tot_nr_b_args,args_nr,nr_a_args);
}
}
void GenPushRArgB (int offset, int tot_nr_a_args, int tot_nr_b_args, int args_nr, int nr_b_args)
{
if (nr_b_args > 0){
put_instruction_b (push_r_args_b);
put_arguments_nnnnn_b (offset,tot_nr_a_args,tot_nr_b_args,args_nr,nr_b_args);
}
}
void GenReplRArgs (int nr_a_args, int nr_b_args)
{
if (nr_a_args + nr_b_args > 0){
put_instruction_b (repl_r_args);
put_arguments_nn_b (nr_a_args,nr_b_args);
} else
GenPopA (1);
}
void GenReplRArgA (int tot_nr_a_args, int tot_nr_b_args, int args_nr, int nr_a_args)
{
if (nr_a_args > 0){
put_instruction_b (repl_r_args_a);
put_arguments_nnnn_b (tot_nr_a_args,tot_nr_b_args,args_nr,nr_a_args);
} else
GenPopA (1);
}
void GenPushNode (Label contlab, int arity)
{
put_instruction_b (push_node);
GenLabel (contlab);
put_arguments__n_b (arity);
}
void GenPushNodeU (Label contlab,int a_size,int b_size)
{
put_instruction_b (push_node_u);
GenLabel (contlab);
put_arguments__nn_b (a_size,b_size);
}
void GenFill (Label symblab,int arity,Label contlab,int offset,FillKind fkind)
{
TreatWaitListBeforeFill (offset, fkind);
put_instruction_b (fill);
if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol))
GenDescriptorOrNodeEntryLabel (symblab);
else
FPutS (empty_lab.lab_name, OutFile);
put_arguments__n__b (arity);
GenDescriptorOrNodeEntryLabel (contlab);
put_arguments__n_b (offset);
if (arity < 0)
arity = 1;
TreatWaitListAfterFill (offset-arity, fkind);
}
void GenFillU (Label symblab,int a_size,int b_size,Label contlab,int offset)
{
put_instruction_ (Ifill_u);
if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol))
GenDescriptorOrNodeEntryLabel (symblab);
else
FPutS (empty_lab.lab_name, OutFile);
FPrintF (OutFile," %d %d ",a_size,b_size);
GenDescriptorOrNodeEntryLabel (contlab);
put_arguments__n_b (offset);
}
void GenFillcp (Label symblab,int arity,Label contlab,int offset,char bits[])
{
put_instruction_b (fillcp);
if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol))
GenDescriptorOrNodeEntryLabel (symblab);
else
FPutS (empty_lab.lab_name, OutFile);
put_arguments__n__b (arity);
GenDescriptorOrNodeEntryLabel (contlab);
put_arguments__n_b (offset);
FPrintF (OutFile," %s",bits);
}
void GenFillcpU (Label symblab,int a_size,int b_size,Label contlab,int offset,char bits[])
{
put_instruction_b (fillcp_u);
if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol))
GenDescriptorOrNodeEntryLabel (symblab);
else
FPutS (empty_lab.lab_name, OutFile);
FPrintF (OutFile," %d %d ",a_size,b_size);
GenDescriptorOrNodeEntryLabel (contlab);
put_arguments__n_b (offset);
FPrintF (OutFile," %s",bits);
}
void GenFillh (Label symblab, int arity, int offset, FillKind fkind)
{
TreatWaitListBeforeFill (offset, fkind);
put_instruction_b (fillh);
if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol))
GenDescriptorOrNodeEntryLabel (symblab);
else
FPutS (empty_lab.lab_name, OutFile);
put_arguments__nn_b (arity,offset);
if (arity < 0)
arity = 1;
TreatWaitListAfterFill (offset-arity, fkind);
}
void GenFill1 (Label symblab,int arity,int offset,char bits[])
{
put_instruction_ (Ifill1);
if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol))
GenLabel (symblab);
else
FPutS (empty_lab.lab_name, OutFile);
FPrintF (OutFile," %d %d %s",arity,offset,bits);
}
void GenFill2 (Label symblab,int arity,int offset,char bits[])
{
put_instruction_ (Ifill2);
GenLabel (symblab);
FPrintF (OutFile," %d %d %s",arity,offset,bits);
}
void GenBuild (Label symblab,int arity,Label contlab)
{
put_instruction_b (build);
if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol))
GenDescriptorOrNodeEntryLabel (symblab);
else
FPutS (empty_lab.lab_name, OutFile);
put_arguments__n__b (arity);
GenDescriptorOrNodeEntryLabel (contlab);
}
void GenBuildh (Label symblab,int arity)
{
put_instruction_b (buildh);
if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol))
GenLabel (symblab);
else
FPutS (empty_lab.lab_name, OutFile);
put_arguments__n_b (arity);
}
void GenBuildPartialFunctionh (Label symblab,int arity)
{
put_instruction_b (buildh);
if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol))
GenDescriptorOrNodeEntryLabel (symblab);
else
FPutS (empty_lab.lab_name, OutFile);
put_arguments__n_b (arity);
}
void GenBuildU (Label symblab,int a_size,int b_size,Label contlab)
{
put_instruction_ (Ibuild_u);
if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol))
GenDescriptorOrNodeEntryLabel (symblab);
else
FPutS (empty_lab.lab_name, OutFile);
FPrintF (OutFile," %d %d ",a_size,b_size);
GenDescriptorOrNodeEntryLabel (contlab);
}
void GenBuildArray (int argoffset)
{
GenPushA (argoffset);
GenBuildh (& BasicDescriptors [ArrayObj], 1);
}
void GenBuildString (SymbValue val)
{
put_instruction_ (IbuildAC);
FPrintF (OutFile, "%s", val.val_string);
}
static void GenFieldLabel (Label label,char *record_name)
{
SymbDef def;
def = (SymbDef) label->lab_name;
if (label->lab_mod)
FPrintF (OutFile,"e_%s_%s%s.%s",
label->lab_mod,label->lab_pref,record_name,def->sdef_ident->ident_name);
else if (DoDebug){
if (def->sdef_kind==IMPRULE)
FPrintF (OutFile, "%s%s.%s.%u",
label->lab_pref,record_name,def->sdef_ident->ident_name,def->sdef_number);
else
FPrintF (OutFile, "%s%s.%s",label->lab_pref,record_name,def->sdef_ident->ident_name);
} else if (def->sdef_number==0)
FPrintF (OutFile, "%s%s",label->lab_pref,def->sdef_ident->ident_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);
}
void GenBuildFieldSelector (Label symblab,Label contlab,char *record_name,int arity)
{
put_instruction_b (build);
if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol))
GenFieldLabel (symblab,record_name);
else
FPutS (empty_lab.lab_name, OutFile);
put_arguments__n__b (arity);
GenFieldLabel (contlab,record_name);
}
void GenFieldLabelDefinition (Label label,char *record_name)
{
FPutS ("\n", OutFile);
GenFieldLabel (label,record_name);
}
void GenFillFieldSelector (Label symblab,Label contlab,char *record_name,int arity,int offset,FillKind fkind)
{
TreatWaitListBeforeFill (offset,fkind);
put_instruction_b (fill);
if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol))
GenFieldLabel (symblab,record_name);
else
FPutS (empty_lab.lab_name, OutFile);
put_arguments__n__b (arity);
GenFieldLabel (contlab,record_name);
put_arguments__n_b (offset);
TreatWaitListAfterFill (offset-1,fkind);
}
void GenFillR (Label symblab,int nr_a_args,int nr_b_args,int rootoffset,int a_offset,int b_offset,FillKind fkind,Bool pop_args)
{
TreatWaitListBeforeFill (rootoffset, fkind);
put_instruction_ (Ifill_r);
if (! symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol))
GenLabel (symblab);
else
FPutS (empty_lab.lab_name, OutFile);
if (nr_a_args==0)
a_offset=0;
if (nr_b_args==0)
b_offset=0;
FPrintF (OutFile, " %d %d %d %d %d",nr_a_args,nr_b_args,rootoffset,a_offset,b_offset);
if (pop_args){
GenPopA (nr_a_args);
GenPopB (nr_b_args);
TreatWaitListAfterFill (rootoffset-nr_a_args, fkind);
} else
TreatWaitListAfterFill (rootoffset, fkind);
}
void GenFill1R (Label symblab,int n_a_args,int n_b_args,int rootoffset,char bits[])
{
put_instruction_ (Ifill1_r);
if (! symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol))
GenLabel (symblab);
else
FPutS (empty_lab.lab_name, OutFile);
FPrintF (OutFile, " %d %d %d %s",n_a_args,n_b_args,rootoffset,bits);
}
void GenFill2R (Label symblab,int n_a_args,int n_b_args,int rootoffset,char bits[])
{
put_instruction_ (Ifill2_r);
if (! symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol))
GenLabel (symblab);
else
FPutS (empty_lab.lab_name, OutFile);
FPrintF (OutFile, " %d %d %d %s",n_a_args,n_b_args,rootoffset,bits);
}
void GenFill3R (Label symblab,int n_a_args,int n_b_args,int rootoffset,char bits[])
{
put_instruction_ (Ifill3_r);
if (! symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol))
GenLabel (symblab);
else
FPutS (empty_lab.lab_name, OutFile);
FPrintF (OutFile, " %d %d %d %s",n_a_args,n_b_args,rootoffset,bits);
}
void GenBuildR (Label symblab,int nr_a_args,int nr_b_args,int a_offset,int b_offset,Bool pop_args)
{
put_instruction_ (Ibuild_r);
if (!symblab->lab_issymbol || DescriptorNeeded (symblab->lab_symbol))
GenLabel (symblab);
else
FPutS (empty_lab.lab_name, OutFile);
if (nr_a_args==0)
a_offset=0;
if (nr_b_args==0)
b_offset=0;
FPrintF (OutFile, " %d %d %d %d",nr_a_args,nr_b_args,a_offset,b_offset);
if (pop_args){
if (nr_a_args>0){
GenUpdateA (0,nr_a_args);
GenPopA (nr_a_args);
}
GenPopB (nr_b_args);
}
}
void GenFillFromA (int src, int dst, FillKind fkind)
{
if (src == dst)
return;
TreatWaitListBeforeFill (dst, fkind);
put_instruction_b (fill_a);
put_arguments_nn_b (src,dst);
TreatWaitListAfterFill (dst, fkind);
}
void GenFillArray (int argoffset, int rootoffset, FillKind fkind)
{
GenPushA (argoffset);
GenFillh (&BasicDescriptors [ArrayObj], 1, rootoffset+1, fkind);
}
void GenPushArray (int rootoffset)
{
put_instruction_ (Ipush_array);
FPrintF (OutFile, "%d", rootoffset);
}
void GenRtn (int asize, int bsize, StateS resultstate)
{
GenDStackLayoutOfState (asize, bsize, resultstate);
put_instructionb (rtn);
}
void GenPushA (int offset)
{
if (offset<0)
error_in_function ("GenPushA");
put_instruction_b (push_a);
put_arguments_n_b (offset);
}
void GenPushB (int offset)
{
if (offset<0)
error_in_function ("GenPushB");
put_instruction_b (push_b);
put_arguments_n_b (offset);
}
void GenJsrEval (int offset)
{
put_instruction_b (jsr_eval);
put_arguments_n_b (offset);
}
void GenJmpEval (void)
{
put_instruction (Ijmp_eval);
}
void GenPopA (int nr)
{
if (nr > 0){
put_instruction_b (pop_a);
put_arguments_n_b (nr);
}
}
void GenPopB (int nr)
{
if (nr > 0){
put_instruction_b (pop_b);
put_arguments_n_b (nr);
}
}
void GenEqDesc (Label symblab,int arity,int offset)
{
put_instruction_b (eq_desc);
GenLabel (symblab);
put_arguments__nn_b (arity,offset);
}
void GenEqD_b (Label symblab,int arity)
{
put_instruction_b (eqD_b);
GenLabel (symblab);
put_arguments__n_b (arity);
}
void GenExitFalse (Label to)
{
put_instruction_ ("exit_false");
GenLabel (to);
}
void GenJmpFalse (Label to)
{
put_instruction_b (jmp_false);
GenLabel (to);
}
void GenJmpTrue (Label to)
{
put_instruction_b (jmp_true);
GenLabel (to);
}
void GenJmp (Label tolab)
{
put_instruction_b (jmp);
GenLabel (tolab);
}
void GenJsr (Label tolab)
{
put_instruction_b (jsr);
GenLabel (tolab);
}
void GenCreate (int arity)
{
if (arity == -1)
put_instruction (Icreate);
else {
put_instruction_ (Icreate);
FPrintF (OutFile, "%d", arity);
}
}
void GenDumpString (char *str)
{
put_instruction_ (Iprint);
FPrintF (OutFile, "\"%s\"", str);
put_instruction (Ihalt);
}
void GenLabelDefinition (Label lab)
{
if (lab){
FPutC ('\n', OutFile);
GenLabel (lab);
}
}
void GenNodeEntryLabelDefinition (Label lab)
{
FPutC ('\n', OutFile);
GenDescriptorOrNodeEntryLabel (lab);
}
void GenUpdateA (int src, int dst)
{
if (src != dst){
put_instruction_b (update_a);
put_arguments_nn_b (src,dst);
}
}
void GenUpdatePopA (int src, int dst)
{
if (src!=dst){
if (dst!=0){
put_instruction_b (updatepop_a);
put_arguments_nn_b (src,dst);
} else {
put_instruction_b (update_a);
put_arguments_nn_b (src,dst);
}
} else
if (dst > 0){
put_instruction_b (pop_a);
put_arguments_n_b (dst);
}
}
void GenUpdateB (int src, int dst)
{
if (src != dst){
put_instruction_b (update_b);
put_arguments_nn_b (src,dst);
}
}
void GenUpdatePopB (int src, int dst)
{
if (src!=dst){
if (dst!=0){
put_instruction_b (updatepop_b);
put_arguments_nn_b (src,dst);
} else {
put_instruction_b (update_b);
put_arguments_nn_b (src,dst);
}
} else
if (dst > 0) {
put_instruction_b (pop_b);
put_arguments_n_b (dst);
}
}
void GenHalt (void)
{
put_instruction (Ihalt);
}
void GenSetRedId (int offset)
{
FPrintF (OutFile, "\n\tset_red_id %d", offset);
}
void GenNewParallelReducer (int offset, char *reducer_code)
{
FPrintF (OutFile, "\n\tnew_ext_reducer %s %d", reducer_code, offset);
}
void GenNewContInterleavedReducer (int offset)
{
FPrintF (OutFile, "\n\tnew_int_reducer _cont_reducer %d", offset);
FPrintF (OutFile, "\n\tforce_cswitch", offset);
}
void GenNewInterleavedReducer (int offset, char *reducer_code)
{
FPrintF (OutFile, "\n\tnew_int_reducer %s %d", reducer_code, offset);
}
void GenSendGraph (char *code, int graphoffs, int chanoffs)
{
FPrintF (OutFile, "\n\tsend_graph %s %d %d", code, graphoffs, chanoffs);
}
void GenCreateChannel (char *code)
{
FPrintF (OutFile, "\n\tcreate_channel %s", code);
}
void GenNewP (void)
{
FPutS ("\n\tnewP", OutFile);
}
void SetContinue (int offset)
{
FPrintF (OutFile, "\n\tset_continue %d", offset);
}
void SetContinueOnReducer (int offset)
{
FPrintF (OutFile, "\n\tset_continue2 %d", offset);
}
void GenGetNodeArity (int offset)
{
put_instruction_ (Iget_node_arity);
FPrintF (OutFile, "%d", offset);
}
static void GenGetDescArity (int offset)
{
put_instruction_ (Iget_desc_arity);
FPrintF (OutFile, "%d", offset);
}
void GenPushArgB (int offset)
{
put_instruction_ (Ipush_arg_b);
FPrintF (OutFile, "%d", offset);
}
void GenImport (SymbDef sdef)
{
if (DoStackLayout){
char *name;
name = sdef->sdef_ident->ident_name;
switch (sdef->sdef_kind){
case DEFRULE:
case SYSRULE:
if (sdef->sdef_mark & (SDEF_USED_CURRIED_MASK | SDEF_USED_LAZILY_MASK)){
put_directive_b (impdesc);
FPrintF (OutFile, "e_%s_" D_PREFIX "%s",sdef->sdef_module,name);
}
if (sdef->sdef_mark & SDEF_USED_STRICTLY_MASK && sdef->sdef_arfun==NoArrayFun){
put_directive_b (implab);
FPrintF (OutFile,"e_%s_" S_PREFIX "%s",sdef->sdef_module,name);
}
break;
case FIELDSELECTOR:
if (sdef->sdef_mark & SDEF_USED_LAZILY_MASK){
char *record_name;
record_name = sdef->sdef_type->type_lhs->ft_symbol->symb_def->sdef_ident->ident_name;
put_directive_b (impdesc);
FPrintF (OutFile, "e_%s_" D_PREFIX "%s.%s",sdef->sdef_module,record_name,name);
put_directive_b (implab);
FPrintF (OutFile, "e_%s_" N_PREFIX "%s.%s",sdef->sdef_module,record_name,name);
if (sdef->sdef_calledwithrootnode)
FPrintF (OutFile, " e_%s_" EA_PREFIX "%s.%s",sdef->sdef_module,record_name,name);
else if (sdef->sdef_returnsnode)
FPutS (" _",OutFile);
}
return;
case RECORDTYPE:
if (sdef->sdef_mark & (SDEF_USED_STRICTLY_MASK | SDEF_USED_LAZILY_MASK)){
put_directive_b (impdesc);
FPrintF (OutFile, "e_%s_" R_PREFIX "%s",sdef->sdef_module,name);
}
if (!sdef->sdef_strict_constructor)
return;
if (sdef->sdef_mark & SDEF_USED_LAZILY_MASK){
put_directive_b (impdesc);
FPrintF (OutFile, "e_%s_" RECORD_D_PREFIX "%s", sdef->sdef_module,name);
put_directive_b (implab);
FPrintF (OutFile, "e_%s_" RECORD_N_PREFIX "%s",sdef->sdef_module,name);
}
return;
case CONSTRUCTOR:
if (!sdef->sdef_strict_constructor)
return;
if (sdef->sdef_mark & (SDEF_USED_STRICTLY_MASK | SDEF_USED_LAZILY_MASK)){
put_directive_b (impdesc);
FPrintF (OutFile, "e_%s_" CONSTRUCTOR_R_PREFIX "%s",sdef->sdef_module,name);
}
if (sdef->sdef_mark & SDEF_USED_LAZILY_MASK){
put_directive_b (impdesc);
FPrintF (OutFile, "e_%s_" D_PREFIX "%s", sdef->sdef_module,name);
}
break;
default:
return;
}
if (sdef->sdef_mark & SDEF_USED_LAZILY_MASK){
put_directive_b (implab);
FPrintF (OutFile, "e_%s_" N_PREFIX "%s",sdef->sdef_module,name);
if ((sdef->sdef_calledwithrootnode || sdef->sdef_returnsnode) &&
!(sdef->sdef_kind==CONSTRUCTOR && !sdef->sdef_strict_constructor))
{
if (sdef->sdef_calledwithrootnode)
FPrintF (OutFile, " e_%s_" EA_PREFIX "%s",sdef->sdef_module,name);
else
FPutS (" _",OutFile);
}
}
}
}
void GenExportStrictAndEaEntry (SymbDef sdef)
{
char *name;
name = sdef->sdef_ident->ident_name;
put_directive_ (Dexport);
FPrintF (OutFile, "e_%s_" S_PREFIX "%s", CurrentModule,name);
if (sdef->sdef_calledwithrootnode){
put_directive_ (Dexport);
FPrintF (OutFile, "e_%s_%s%s", CurrentModule, ea_pref, name);
}
}
void GenExportFieldSelector (SymbDef sdef)
{
char *name;
char *record_name;
name = sdef->sdef_ident->ident_name;
record_name=sdef->sdef_type->type_lhs->ft_symbol->symb_def->sdef_ident->ident_name;
put_directive_ (Dexport);
FPrintF (OutFile,"e_%s_" D_PREFIX "%s.%s",CurrentModule,record_name,name);
put_directive_ (Dexport);
FPrintF (OutFile,"e_%s_" N_PREFIX "%s.%s",CurrentModule,record_name,name);
if (sdef->sdef_calledwithrootnode){
put_directive_ (Dexport);
FPrintF (OutFile,"e_%s_" EA_PREFIX "%s.%s",CurrentModule,record_name,name);
}
}
void GenExportEaEntry (SymbDef sdef)
{
if (sdef->sdef_calledwithrootnode){
put_directive_ (Dexport);
FPrintF (OutFile,"e_%s_" EA_PREFIX "%s",CurrentModule,sdef->sdef_ident->ident_name);
}
}
void GenDAStackLayout (int asize)
{
if (DoStackLayout){
put_directive_b (d);
put_arguments_nn_b (asize,0);
}
}
void GenOAStackLayout (int asize)
{
if (DoStackLayout){
put_directive_b (o);
put_arguments_nn_b (asize,0);
}
}
void GenDStackLayoutOfStates (int asize,int bsize,int n_states,StateP state_p)
{
if (DoStackLayout){
put_directive_b (d);
if (bsize > 0){
int i;
put_arguments_nn__b (asize,bsize);
for (i=0; i<n_states; ++i)
GenBStackElems (state_p[i]);
} else
put_arguments_nn_b (asize,0);
}
}
void GenOStackLayoutOfStates (int asize,int bsize,int n_states,StateP state_p)
{
if (DoStackLayout){
put_directive_b (o);
if (bsize > 0){
int i;
put_arguments_nn__b (asize,bsize);
for (i=0; i<n_states; ++i)
GenBStackElems (state_p[i]);
} else
put_arguments_nn_b (asize,0);
}
}
void GenDStackLayoutOfState (int asize, int bsize, StateS resultstate)
{
if (DoStackLayout){
put_directive_b (d);
if (bsize > 0){
put_arguments_nn__b (asize,bsize);
GenBStackElems (resultstate);
} else
put_arguments_nn_b (asize,0);
}
}
void GenOStackLayoutOfState (int asize, int bsize, StateS resultstate)
{
if (DoStackLayout){
put_directive_b (o);
if (bsize > 0){
put_arguments_nn__b (asize,bsize);
GenBStackElems (resultstate);
} else
put_arguments_nn_b (asize,0);
}
}
void GenJmpEvalUpdate (void)
{
put_instruction (Ijmp_eval_upd);
}
void GenNodeEntryDirective (int arity,Label label,Label label2)
{
if (DoStackLayout){
put_directive_b (n);
put_arguments_n__b (arity);
if (DescriptorNeeded (label->lab_symbol))
GenDescriptorOrNodeEntryLabel (label);
else
FPutS (empty_lab.lab_name, OutFile);
if (label2){
FPutC (' ', OutFile);
GenLabel (label2);
}
#ifdef MEMORY_PROFILING_WITH_N_STRING
if (DoProfiling && arity>=0 && !DoParallel){
put_directive_ (Dn_string);
FPrintF (OutFile,"\"%s\"",label->lab_symbol->sdef_ident->ident_name);
}
#endif
}
}
void GenLazyRecordNodeEntryDirective (int arity,Label label)
{
if (DoStackLayout){
put_directive_b (n);
put_arguments_n__b (arity);
if (DescriptorNeeded (label->lab_symbol))
GenLabel (label);
else
FPutS (empty_lab.lab_name, OutFile);
#ifdef MEMORY_PROFILING_WITH_N_STRING
if (DoProfiling && arity>=0 && !DoParallel){
put_directive_ (Dn_string);
FPrintF (OutFile,"\"%s\"",label->lab_symbol->sdef_ident->ident_name);
}
#endif
}
}
void GenNodeEntryDirectiveForLabelWithoutSymbol (int arity,Label label,Label label2)
{
if (DoStackLayout){
put_directive_b (n);
put_arguments_n__b (arity);
GenLabel (label);
if (label2){
FPutC (' ', OutFile);
GenLabel (label2);
}
#ifdef MEMORY_PROFILING_WITH_N_STRING
if (DoProfiling && arity>=0 && !DoParallel){
put_directive_ (Dn_string);
FPrintF (OutFile,"\"%s\"",label->lab_name);
}
#endif
}
}
void GenNodeEntryDirectiveUnboxed (int a_size,int b_size,Label label,Label label2)
{
if (DoStackLayout){
put_directive_ (Dnu);
FPrintF (OutFile,"%d %d ",a_size,b_size);
if (DescriptorNeeded (label->lab_symbol))
GenDescriptorOrNodeEntryLabel (label);
else
FPutS (empty_lab.lab_name, OutFile);
if (label2){
FPutC (' ', OutFile);
GenLabel (label2);
}
# ifdef MEMORY_PROFILING_WITH_N_STRING
if (DoProfiling && !DoParallel){
put_directive_ (Dn_string);
FPrintF (OutFile,"\"%s\"",label->lab_symbol->sdef_ident->ident_name);
}
# endif
}
}
void GenFieldNodeEntryDirective (int arity,Label label,Label label2,char *record_name)
{
if (DoStackLayout){
put_directive_b (n);
put_arguments_n__b (arity);
if (DescriptorNeeded (label->lab_symbol))
GenFieldLabel (label,record_name);
else
FPutS (empty_lab.lab_name, OutFile);
if (label2){
FPutC (' ', OutFile);
GenFieldLabel (label2,record_name);
}
}
}
void GenConstructorDescriptorAndExport (SymbDef sdef)
{
char *name;
LabDef *add_argument_label;
name = sdef->sdef_ident->ident_name;
if (sdef->sdef_arity>0)
add_argument_label=&add_arg_lab;
else
add_argument_label=&hnf_lab;
if (sdef->sdef_exported || ExportLocalLabels){
put_directive_ (Dexport);
FPrintF (OutFile, "e_%s_" D_PREFIX "%s",CurrentModule,name);
put_directive_ (Ddesc);
FPrintF (OutFile, "e_%s_" D_PREFIX "%s %s %s %d 0 \"%s\"",
CurrentModule, name, hnf_lab.lab_name, add_argument_label->lab_name,
sdef->sdef_arity, name);
} else if (DoDebug){
put_directive_ (Ddesc);
FPrintF (OutFile, D_PREFIX "%s %s %s %d 0 \"%s\"",
name,hnf_lab.lab_name, add_argument_label->lab_name, sdef->sdef_arity, name);
} else {
put_directive_ (Ddesc);
FPrintF (OutFile, LOCAL_D_PREFIX "%u %s %s %d 0 \"%s\"",
sdef->sdef_number, hnf_lab.lab_name, add_argument_label->lab_name,
sdef->sdef_arity, name);
}
}
void GenRecordDescriptor (SymbDef sdef)
{
int asize,bsize;
char *name;
StateS recstate;
name = sdef->sdef_ident->ident_name;
if (sdef->sdef_exported || ExportLocalLabels){
put_directive_ (Dexport);
FPrintF (OutFile, "e_%s_" R_PREFIX "%s",CurrentModule,name);
put_directive_ (Drecord);
FPrintF (OutFile, "e_%s_" R_PREFIX "%s ",CurrentModule,name);
} else if (DoDebug){
put_directive_ (Drecord);
FPrintF (OutFile, R_PREFIX "%s ",name);
} else {
put_directive_ (Drecord);
FPrintF (OutFile, R_PREFIX "%u ",sdef->sdef_number);
}
recstate = sdef->sdef_record_state;
GenABStackElems (recstate);
DetermineSizeOfState (recstate,&asize,&bsize);
FPrintF (OutFile, " %d %d \"%s\"",asize,bsize,name);
}
#ifdef STRICT_LISTS
void GenUnboxedConsRecordDescriptor (SymbDef sdef,int tail_strict)
{
int asize,bsize;
char *name,*unboxed_record_cons_prefix;
StateS tuple_state,tuple_arguments_state[2];
name = sdef->sdef_ident->ident_name;
unboxed_record_cons_prefix=tail_strict ? "r_Cons#!" : "r_Cons#";
if (ExportLocalLabels){
put_directive_ (Dexport);
FPrintF (OutFile, "e_%s_%s%s",CurrentModule,unboxed_record_cons_prefix,name);
put_directive_ (Drecord);
FPrintF (OutFile, "e_%s_%s%s ",CurrentModule,unboxed_record_cons_prefix,name);
} else {
put_directive_ (Drecord);
FPrintF (OutFile, "%s%s ",unboxed_record_cons_prefix,name);
}
tuple_state.state_type=TupleState;
tuple_state.state_arity=2;
tuple_state.state_tuple_arguments=tuple_arguments_state;
tuple_arguments_state[0] = sdef->sdef_record_state;
tuple_arguments_state[1] = LazyState;
GenABStackElems (tuple_state);
DetermineSizeOfState (tuple_state,&asize,&bsize);
FPrintF (OutFile,tail_strict ? " %d %d \"[#%s!]\"" : " %d %d \"[#%s]\"",asize,bsize,name);
}
#endif
void GenStrictConstructorDescriptor (SymbDef sdef,StateP constructor_arg_state_p)
{
int asize,bsize,state_arity,arg_n;
char *name;
name = sdef->sdef_ident->ident_name;
if (sdef->sdef_exported || ExportLocalLabels){
put_directive_ (Dexport);
FPrintF (OutFile, "e_%s_" CONSTRUCTOR_R_PREFIX "%s",CurrentModule,name);
put_directive_ (Drecord);
FPrintF (OutFile, "e_%s_" CONSTRUCTOR_R_PREFIX "%s ",CurrentModule,name);
} else if (DoDebug){
put_directive_ (Drecord);
FPrintF (OutFile, CONSTRUCTOR_R_PREFIX "%s ",name);
} else {
put_directive_ (Drecord);
FPrintF (OutFile, CONSTRUCTOR_R_PREFIX "%u ",sdef->sdef_number);
}
FPutC ('d', OutFile);
state_arity=sdef->sdef_arity;
asize = 0;
bsize = 0;
for (arg_n=0; arg_n<state_arity; ++arg_n){
GenABStackElems (*constructor_arg_state_p);
AddSizeOfState (*constructor_arg_state_p,&asize,&bsize);
++constructor_arg_state_p;
}
FPrintF (OutFile, " %d %d \"%s\"", asize, bsize, name);
}
void GenArrayFunctionDescriptor (SymbDef arr_fun_def, Label desclab, int arity)
{
LabDef descriptor_label;
char *name;
name = arr_fun_def->sdef_ident->ident_name;
if (ExportLocalLabels){
put_directive_ (Dexport);
FPrintF (OutFile,"e_%s_" D_PREFIX "%s",CurrentModule,name);
}
descriptor_label=*desclab;
descriptor_label.lab_pref=d_pref;
if (arr_fun_def->sdef_mark & SDEF_USED_CURRIED_MASK)
put_directive_ (Ddesc);
else
put_directive_ (Ddescn);
if (ExportLocalLabels)
FPrintF (OutFile,"e_%s_" D_PREFIX "%s ",CurrentModule,name);
else
GenLabel (&descriptor_label);
FPutC (' ', OutFile);
GenLabel (&empty_lab);
FPutC (' ', OutFile);
if (arr_fun_def->sdef_mark & SDEF_USED_CURRIED_MASK){
LabDef lazylab;
lazylab = *desclab;
lazylab.lab_pref = l_pref;
GenLabel (&lazylab);
}
FPrintF (OutFile, " %d 0 \"%s\"", arity, name);
}
void GenFunctionDescriptorAndExportNodeAndDescriptor (SymbDef sdef)
{
Ident name_id;
char *name;
if (!DescriptorNeeded (sdef))
return;
name_id = sdef->sdef_ident;
name = name_id->ident_name;
if (sdef->sdef_exported){
put_directive_ (Ddescexp);
FPrintF (OutFile, "e_%s_" D_PREFIX "%s e_%s_" N_PREFIX "%s e_%s_" L_PREFIX "%s ",
CurrentModule,name,CurrentModule,name,CurrentModule,name);
} else {
if (sdef->sdef_mark & SDEF_USED_CURRIED_MASK){
int sdef_n;
sdef_n=sdef->sdef_number;
if (ExportLocalLabels){
put_directive_ (Dexport);
FPrintF (OutFile,"e_%s_" D_PREFIX "%s.%u",CurrentModule,name,sdef_n);
if (sdef->sdef_mark & SDEF_USED_LAZILY_MASK){
put_directive_ (Dexport);
FPrintF (OutFile,"e_%s_" N_PREFIX "%s.%u",CurrentModule,name,sdef_n);
}
put_directive_ (Ddesc);
FPrintF (OutFile,"e_%s_" D_PREFIX "%s.%u ",CurrentModule,name,sdef_n);
} else {
put_directive_ (Ddesc);
if (DoDebug)
FPrintF (OutFile,D_PREFIX "%s.%u ",name,sdef_n);
else
FPrintF (OutFile,LOCAL_D_PREFIX "%u ",sdef_n);
}
if (sdef->sdef_mark & SDEF_USED_LAZILY_MASK){
if (ExportLocalLabels)
FPrintF (OutFile,"e_%s_" N_PREFIX "%s.%u ",CurrentModule,name,sdef_n);
else if (DoDebug)
FPrintF (OutFile,N_PREFIX "%s.%u ",name,sdef_n);
else
FPrintF (OutFile,N_PREFIX "%u ",sdef_n);
} else
FPrintF (OutFile, "%s ", hnf_lab.lab_name);
if (DoDebug)
FPrintF (OutFile,L_PREFIX "%s.%u ",name,sdef_n);
else
FPrintF (OutFile,L_PREFIX "%u ",sdef_n);
} else {
int sdef_n;
sdef_n=sdef->sdef_number;
if (ExportLocalLabels){
put_directive_ (Dexport);
FPrintF (OutFile,"e_%s_" D_PREFIX "%s.%u",CurrentModule,name,sdef_n);
if (sdef->sdef_mark & SDEF_USED_LAZILY_MASK){
put_directive_ (Dexport);
FPrintF (OutFile,"e_%s_" N_PREFIX "%s.%u",CurrentModule,name,sdef_n);
}
put_directive_ (Ddescn);
FPrintF (OutFile,"e_%s_" D_PREFIX "%s.%u ",CurrentModule,name,sdef_n);
} else {
put_directive_ (Ddescn);
if (DoDebug)
FPrintF (OutFile,D_PREFIX "%s.%u ",name,sdef_n);
else
FPrintF (OutFile,LOCAL_D_PREFIX "%u ",sdef_n);
}
if (sdef->sdef_mark & SDEF_USED_LAZILY_MASK){
if (ExportLocalLabels)
FPrintF (OutFile,"e_%s_" N_PREFIX "%s.%u ",CurrentModule,name,sdef_n);
else if (DoDebug)
FPrintF (OutFile,N_PREFIX "%s.%u ",name,sdef_n);
else
FPrintF (OutFile,N_PREFIX "%u ",sdef_n);
} else
FPrintF (OutFile, "%s ", hnf_lab.lab_name);
}
}
FPrintF (OutFile, "%d 0 \"", sdef->sdef_arity);
if (ExportLocalLabels){
if (sdef->sdef_exported)
FPrintF (OutFile,"%s",name);
else
FPrintF (OutFile,"%s.%u",name,sdef->sdef_number);
} else
PrintSymbolOfIdent (name_id, 0, OutFile);
FPutC ('\"',OutFile);
}
void GenConstructorFunctionDescriptorAndExportNodeAndDescriptor (SymbDef sdef)
{
Ident name_id;
char *name;
if (!DescriptorNeeded (sdef))
return;
name_id = sdef->sdef_ident;
name = name_id->ident_name;
if (sdef->sdef_exported){
put_directive_ (Ddescexp);
FPrintF (OutFile, "e_%s_" D_PREFIX "%s e_%s_" N_PREFIX "%s e_%s_" L_PREFIX "%s ",
CurrentModule,name,CurrentModule,name,CurrentModule,name);
} else if (ExportLocalLabels && (sdef->sdef_mark & SDEF_USED_CURRIED_MASK)!=0){
put_directive_ (Ddescexp);
if (DoDebug)
FPrintF (OutFile, "e_%s_" D_PREFIX "%s e_%s_" N_PREFIX "%s " L_PREFIX "%s ",
CurrentModule,name,CurrentModule,name,name);
else
FPrintF (OutFile, "e_%s_" D_PREFIX "%s e_%s_" N_PREFIX "%s " L_PREFIX "%u ",
CurrentModule,name,CurrentModule,name,sdef->sdef_number);
} else {
if (sdef->sdef_mark & SDEF_USED_CURRIED_MASK){
put_directive_ (Ddesc);
if (DoDebug)
FPrintF (OutFile, D_PREFIX "%s ",name);
else
FPrintF (OutFile, LOCAL_D_PREFIX "%u ", sdef->sdef_number);
if (sdef->sdef_mark & SDEF_USED_LAZILY_MASK){
if (DoDebug)
FPrintF (OutFile,N_PREFIX "%s ",name);
else
FPrintF (OutFile,N_PREFIX "%u ",sdef->sdef_number);
} else
FPrintF (OutFile, "%s ", hnf_lab.lab_name);
if (DoDebug)
FPrintF (OutFile,L_PREFIX "%s ",name);
else
FPrintF (OutFile,L_PREFIX "%u ",sdef->sdef_number);
} else {
if (ExportLocalLabels){
put_directive_ (Dexport);
FPrintF (OutFile,"e_%s_" N_PREFIX "%s",CurrentModule,name);
}
put_directive_ (Ddescn);
if (DoDebug)
FPrintF (OutFile, D_PREFIX "%s ", name);
else
FPrintF (OutFile, LOCAL_D_PREFIX "%u ", sdef->sdef_number);
if (ExportLocalLabels)
FPrintF (OutFile,"e_%s_" N_PREFIX "%s ",CurrentModule,name);
else if (sdef->sdef_mark & SDEF_USED_LAZILY_MASK){
if (DoDebug)
FPrintF (OutFile,N_PREFIX "%s ", name);
else
FPrintF (OutFile,N_PREFIX "%u ",sdef->sdef_number);
} else
FPrintF (OutFile, "%s ", hnf_lab.lab_name);
}
}
FPrintF (OutFile, "%d 0 \"", sdef->sdef_arity);
PrintSymbolOfIdent (name_id, 0, OutFile);
FPutC ('\"',OutFile);
}
#if OPTIMIZE_LAZY_TUPLE_RECURSION
void GenFunctionDescriptorForLazyTupleRecursion (SymbDef sdef,int tuple_result_arity)
{
Ident name_id;
char *name;
name_id = sdef->sdef_ident;
name = name_id->ident_name;
put_directive_ (Ddescn);
if (sdef->sdef_exported){
FPrintF (OutFile,"e_%s_" D_PREFIX "%s.2 ",CurrentModule,name);
FPrintF (OutFile,"e_%s_" N_PREFIX "%s.2 ",CurrentModule,name);
} else if (DoDebug){
FPrintF (OutFile,D_PREFIX "%s.%u.2 ",name,sdef->sdef_number);
FPrintF (OutFile,N_PREFIX "%s.%u.2 ",name,sdef->sdef_number);
} else {
FPrintF (OutFile,LOCAL_D_PREFIX "%u.2 ",sdef->sdef_number);
FPrintF (OutFile,N_PREFIX "%u.2 ",sdef->sdef_number);
}
FPrintF (OutFile, "%d 0 \"",sdef->sdef_arity+tuple_result_arity);
PrintSymbolOfIdent (name_id,0,OutFile);
FPutC ('\"',OutFile);
# if 1
put_directive_ (Ddescn);
if (sdef->sdef_exported){
FPrintF (OutFile,"e_%s_" D_PREFIX "%s.3 ",CurrentModule,name);
FPrintF (OutFile,"e_%s_" N_PREFIX "%s.3 ",CurrentModule,name);
} else if (DoDebug){
FPrintF (OutFile,D_PREFIX "%s.%u.3 ",name,sdef->sdef_number);
FPrintF (OutFile,N_PREFIX "%s.%u.3 ",name,sdef->sdef_number);
} else {
FPrintF (OutFile,LOCAL_D_PREFIX "%u.3 ",sdef->sdef_number);
FPrintF (OutFile,N_PREFIX "%u.3 ",sdef->sdef_number);
}
FPrintF (OutFile, "%d 0 \"",sdef->sdef_arity+tuple_result_arity);
PrintSymbolOfIdent (name_id,0,OutFile);
FPutC ('\"',OutFile);
# endif
}
#endif
void GenLazyRecordDescriptorAndExport (SymbDef sdef)
{
char *name;
int arity;
if (!DescriptorNeeded (sdef))
return;
name = sdef->sdef_ident->ident_name;
arity = sdef->sdef_cons_arity;
if (sdef->sdef_exported){
put_directive_ (Ddescexp);
FPrintF (OutFile, "e_%s_" RECORD_D_PREFIX "%s e_%s_" RECORD_N_PREFIX "%s _hnf %d 1 \"%s\"",
CurrentModule,name,CurrentModule,name,arity,name);
} else {
if (ExportLocalLabels){
put_directive_ (Dexport);
FPrintF (OutFile,"e_%s_" RECORD_N_PREFIX "%s",CurrentModule,name);
}
put_directive_ (Ddescn);
if (DoDebug){
if (ExportLocalLabels){
FPrintF (OutFile,"e_%s_" RECORD_D_PREFIX "%s ",CurrentModule,name);
FPrintF (OutFile,"e_%s_" RECORD_N_PREFIX "%s ",CurrentModule,name);
} else
FPrintF (OutFile,RECORD_D_PREFIX "%s " RECORD_N_PREFIX "%s ",name,name);
} else {
if (ExportLocalLabels){
FPrintF (OutFile,"e_%s_" RECORD_D_PREFIX "%s ",CurrentModule,name);
FPrintF (OutFile,"e_%s_" RECORD_N_PREFIX "%s ",CurrentModule,name);
} else
FPrintF (OutFile,RECORD_D_PREFIX "%u " RECORD_N_PREFIX "%u ",sdef->sdef_number,sdef->sdef_number);
}
FPrintF (OutFile, "%d 1 \"%s\"",arity,name);
}
}
void GenFieldSelectorDescriptor (SymbDef sdef,int has_gc_apply_entry)
{
char *name;
int arity;
if (!DescriptorNeeded (sdef))
return;
name = sdef->sdef_ident->ident_name;
arity = (sdef->sdef_kind == RECORDTYPE) ? sdef->sdef_cons_arity : sdef->sdef_arity;
put_directive_ (Ddesc);
if (sdef->sdef_exported){
char *record_name;
record_name=sdef->sdef_type->type_lhs->ft_symbol->symb_def->sdef_ident->ident_name;
if (has_gc_apply_entry)
FPrintF (OutFile, "e_%s_" D_PREFIX "%s.%s e_%s_" N_PREFIX "%s.%s e_%s_%s%s.%s %d 0 \"%s\"",
CurrentModule,record_name,name,
CurrentModule,record_name,name,
CurrentModule,l_pref,record_name,name,
arity, name);
else
FPrintF (OutFile, "e_%s_" D_PREFIX "%s.%s e_%s_" N_PREFIX "%s.%s _hnf %d 0 \"%s\"",
CurrentModule,record_name,name,
CurrentModule,record_name,name,
arity, name);
} else if ((sdef->sdef_mark & SDEF_USED_LAZILY_MASK) || has_gc_apply_entry){
char *record_name;
record_name = sdef->sdef_type->type_lhs->ft_symbol->symb_def->sdef_ident->ident_name;
if (DoDebug)
FPrintF (OutFile, D_PREFIX "%s.%s ",record_name,name);
else
FPrintF (OutFile, LOCAL_D_PREFIX "%u ", sdef->sdef_number);
if (sdef->sdef_mark & SDEF_USED_LAZILY_MASK){
if (DoDebug)
FPrintF (OutFile, N_PREFIX "%s.%s ",record_name,name);
else
FPrintF (OutFile, N_PREFIX "%u ",sdef->sdef_number);
} else
FPrintF (OutFile, "%s ", hnf_lab.lab_name);
if (has_gc_apply_entry){
if (DoDebug)
FPrintF (OutFile, "%s%s.%s ",l_pref,record_name,name);
else
FPrintF (OutFile, "%s%u ",l_pref,sdef->sdef_number);
} else
FPrintF (OutFile, "%s ", hnf_lab.lab_name);
FPrintF (OutFile, "%d 0 \"%s\"", arity, name);
} else if (DoDebug){
FPrintF (OutFile, D_PREFIX "%s %s %s %d 0 \"%s\"", name, hnf_lab.lab_name,
hnf_lab.lab_name, arity, name);
} else
FPrintF (OutFile, LOCAL_D_PREFIX "%u %s %s %d 0 \"%s\"", sdef->sdef_number,
hnf_lab.lab_name, hnf_lab.lab_name, arity, name);
}
void GenModuleDescriptor (
#if WRITE_DCL_MODIFICATION_TIME
ModuleFileTime file_time
#else
void
#endif
)
{
put_directive_ (Dmodule);
FPrintF (OutFile, "m_%s \"%s\"", CurrentModule,CurrentModule);
#if WRITE_DCL_MODIFICATION_TIME
if (WriteModificationTimes){
FPutC (' ',OutFile);
FPutC ('\"',OutFile);
# if CLEAN2
FPutS (file_time,OutFile);
# else
FWriteFileTime (file_time,OutFile);
# endif
FPutC ('\"',OutFile);
}
#endif
}
void GenDepend (char *modname
#if WRITE_DCL_MODIFICATION_TIME
,ModuleFileTime file_time
#endif
)
{
#ifndef _STANDALONE_
AddDependency (modname);
#endif
put_directive_ (Ddepend);
FPrintF (OutFile, "\"%s\"",modname);
#if WRITE_DCL_MODIFICATION_TIME
if (WriteModificationTimes){
FPutC (' ',OutFile);
FPutC ('\"',OutFile);
# if CLEAN2
FPutS (file_time,OutFile);
# else
FWriteFileTime (file_time,OutFile);
# endif
FPutC ('\"',OutFile);
}
#endif
}
void GenStart (SymbDef startsymb)
{
if (startsymb->sdef_module == CurrentModule){
int arity;
arity = startsymb->sdef_arity;
startsymb->sdef_mark |= SDEF_USED_LAZILY_MASK;
put_directive_ (Dexport);
FPrintF (OutFile, "__%s_Start", CurrentModule);
GenOAStackLayout (0);
FPrintF (OutFile, "\n__%s_Start", CurrentModule);
if (arity!=0){
put_instruction_b (buildI);
put_arguments_n_b (65536l);
}
put_instruction_b (build);
if (startsymb->sdef_exported)
FPrintF (OutFile, "e_%s_" D_PREFIX "Start",CurrentModule);
else if (ExportLocalLabels)
if (DoParallel)
FPrintF (OutFile,"e_%s_" D_PREFIX "Start.%u",CurrentModule,startsymb->sdef_number);
else
FPutS (empty_lab.lab_name, OutFile);
else if (DoDebug){
if (DoParallel)
FPrintF (OutFile, D_PREFIX "Start.%u",startsymb->sdef_number);
else
FPutS (empty_lab.lab_name, OutFile);
} else {
if (DoParallel)
FPrintF (OutFile, LOCAL_D_PREFIX "%u",startsymb->sdef_number);
else
FPutS (empty_lab.lab_name, OutFile);
}
put_arguments__n__b (arity);
if (startsymb->sdef_exported)
FPrintF (OutFile, "e_%s_" N_PREFIX "Start",CurrentModule);
else if (ExportLocalLabels)
FPrintF (OutFile, "e_%s_" N_PREFIX "Start.%u",CurrentModule,startsymb->sdef_number);
else if (DoDebug)
FPrintF (OutFile, N_PREFIX "Start.%u",startsymb->sdef_number);
else
FPrintF (OutFile, N_PREFIX "%u",startsymb->sdef_number);
GenDAStackLayout (1);
put_instruction_b (jmp);
FPutS ("_driver", OutFile);
}
}
void GenSelectorDescriptor (Label sellab,char *g_pref)
{
put_directive_ (Ddesc);
FPrintF (OutFile, D_PREFIX "%s.%d %s%s.%d %s%s.%d 1 0 \"%s.%d\"",
sellab->lab_name, sellab->lab_post,
sellab->lab_pref, sellab->lab_name, sellab->lab_post,
g_pref, sellab->lab_name, sellab->lab_post,
sellab->lab_name, sellab->lab_post);
}
void InitFileInfo (ImpMod imod)
{
char option_string[NR_OPTIONS+1];
CompilerOptions opts;
SymbDef start_sdef;
start_sdef=imod->im_start;
#ifndef _STANDALONE_
MakeOptionsFromCurrentOptions (& opts);
#endif
ConvertOptionsToString (opts,option_string);
if (imod->im_def_module!=NULL && imod->im_def_module->dm_system_module)
option_string[N_System]='1';
put_first_directive_ (Dcomp);
FPrintF (OutFile, "%d %s", VERSION,option_string);
#ifndef _STANDALONE_
AddVersionAndOptions (VERSION, opts);
#endif
put_directive_ (Dcode);
FPrintF (OutFile, "%7ld %7ld %7ld", (long) 0, (long) 0, (long) 0);
put_directive_ (Dstart);
if (start_sdef!=NULL){
FPrintF (OutFile, "__%s_Start",start_sdef->sdef_module);
} else
FPutS ("_nostart_", OutFile);
}
void GenNoMatchError (SymbDef sdef,int asp,int bsp,int string_already_generated)
{
Bool desc_needed;
desc_needed = DescriptorNeeded (sdef);
GenPopA (asp);
GenPopB (bsp);
put_instruction_b (pushD);
FPrintF (OutFile, "m_%s", CurrentModule);
put_instruction_b (pushD);
if (!desc_needed)
FPrintF (OutFile, "x_%u", sdef->sdef_number);
else if (sdef->sdef_exported)
FPrintF (OutFile, "e_%s_" D_PREFIX "%s", CurrentModule, sdef->sdef_ident->ident_name);
else if (ExportLocalLabels){
if (sdef->sdef_kind==IMPRULE)
FPrintF (OutFile,"e_%s_" D_PREFIX "%s.%u",CurrentModule,sdef->sdef_ident->ident_name,sdef->sdef_number);
else
FPrintF (OutFile,"e_%s_" D_PREFIX "%s",CurrentModule,sdef->sdef_ident->ident_name);
} else if (DoDebug){
if (sdef->sdef_kind==IMPRULE)
FPrintF (OutFile, D_PREFIX "%s.%u", sdef->sdef_ident->ident_name,sdef->sdef_number);
else
FPrintF (OutFile, D_PREFIX "%s", sdef->sdef_ident->ident_name);
} else
FPrintF (OutFile, LOCAL_D_PREFIX "%u", sdef->sdef_number);
if (DoStackLayout){
put_directive_b (d);
put_arguments_nn__b (0,2);
FPutS ("ii",OutFile);
}
GenJmp (&match_error_lab);
if (!desc_needed && !string_already_generated){
put_directive_ (Dstring);
FPrintF (OutFile, "x_%u \"",sdef->sdef_number);
PrintSymbolOfIdent (sdef->sdef_ident, sdef->sdef_line,OutFile);
FPutS ("\"", OutFile);
}
}
#if CLEAN2
void GenCaseNoMatchError (SymbDefP case_def,int asp,int bsp)
{
static int case_number;
GenPopA (asp);
GenPopB (bsp);
put_instruction_b (pushD);
FPrintF (OutFile, "m_%s", CurrentModule);
put_instruction_b (pushD);
FPrintF (OutFile, "case_fail%u",case_number);
GenJmp (&match_error_lab);
put_directive_ (Dstring);
FPrintF (OutFile, "case_fail%u \"",case_number);
PrintSymbolOfIdent (case_def->sdef_ident,case_def->sdef_line,OutFile);
FPrintF (OutFile, "\"");
case_number++;
}
#endif
static void GenImpLab (char *label_name)
{
put_directive_b (implab);
FPutS (label_name,OutFile);
}
static void GenImpLab_node_entry (char *label_name,char *ea_label_name)
{
put_directive_b (implab);
FPrintF (OutFile,"%s %s",label_name,ea_label_name);
}
static void GenImpDesc (char *descriptor_name)
{
put_directive_b (impdesc);
FPutS (descriptor_name,OutFile);
}
void GenEndInfo (void)
{
put_directive (Dendinfo);
}
void GenSystemImports (void)
{
if (DoStackLayout){
/* system module labels and descriptors */
int selnum;
if (DoParallel){
GenImpLab (channel_code);
GenImpLab (hnf_reducer_code);
GenImpDesc (ext_hnf_reducer_code);
GenImpLab (nf_reducer_code);
GenImpDesc (ext_nf_reducer_code);
GenImpLab (reserve_lab.lab_name);
}
GenImpLab (cycle_lab.lab_name);
GenImpLab (type_error_lab.lab_name);
GenImpLab (hnf_lab.lab_name);
GenImpDesc ("_ind");
GenImpLab_node_entry (indirection_lab.lab_name,"_eaind");
GenImpDesc ("e_system_dif");
GenImpLab_node_entry ("e_system_nif","e_system_eaif");
GenImpLab ("e_system_sif");
GenImpDesc ("e_system_dAP");
GenImpLab_node_entry ("e_system_nAP","e_system_eaAP");
GenImpLab ("e_system_sAP");
GenImpDesc (nil_lab.lab_name);
GenImpDesc (cons_lab.lab_name);
#if STRICT_LISTS
GenImpDesc (conss_lab.lab_name);
GenImpLab_node_entry ("n_Conss","ea_Conss");
GenImpDesc (consts_lab.lab_name);
GenImpLab_node_entry ("n_Consts","ea_Consts");
GenImpDesc (conssts_lab.lab_name);
GenImpLab_node_entry ("n_Conssts","ea_Conssts");
#endif
GenImpDesc (tuple_lab.lab_name);
for (selnum=1; selnum<=NrOfGlobalSelectors; ++selnum){
put_directive_b (impdesc);
FPrintF (OutFile,D_PREFIX "%s.%d",glob_sel,selnum);
put_directive_b (implab);
FPrintF (OutFile,N_PREFIX "%s.%d " EA_PREFIX "%s.%d",glob_sel,selnum,glob_sel,selnum);
}
#ifdef THUNK_LIFT_SELECTORS
for (selnum=1; selnum<=NrOfGlobalSelectors; ++selnum){
put_directive_b (impdesc);
FPrintF (OutFile,D_PREFIX "%s.%d",glob_selr,selnum);
put_directive_b (implab);
FPrintF (OutFile,N_PREFIX "%s.%d " EA_PREFIX "%s.%d",glob_selr,selnum,glob_selr,selnum);
}
#endif
GenImpLab ("_driver");
}
}
void GenParameters (Bool input, Parameters params, int asp, int bsp)
{
int is_first_parameter;
if (input)
put_instruction_ (Iin);
else
put_instruction_ (Iout);
is_first_parameter=1;
for (; params!=NULL; params=params->par_next){
NodeId node_id;
node_id=params->par_node_id;
if (!is_first_parameter)
FPutC (' ',OutFile);
if (IsSimpleState (node_id->nid_state) && node_id->nid_state.state_kind==OnB)
FPrintF (OutFile, "b%d:%s",bsp-node_id->nid_b_index,params->par_loc->ident_name);
else
FPrintF (OutFile, "a%d:%s",asp-node_id->nid_a_index,params->par_loc->ident_name);
is_first_parameter=0;
}
}
void GenInstructions (Instructions ilist)
{
for (; ilist; ilist = ilist->instr_next){
char *instruction_name;
instruction_name=ilist->instr_this;
FPutC ('\n',OutFile);
if (instruction_name[0]==':')
FPutS (&instruction_name[1],OutFile);
else {
if (instruction_name[0]!='.')
FPutC ('\t',OutFile);
FPutS (instruction_name,OutFile);
}
}
if (!DoDebug)
FPutC ('\n',OutFile);
}
void GenTestCaf (Label label)
{
put_instruction_ (Itestcaf);
GenLabel (label);
}
void GenPushCaf (Label label,int a_stack_size,int b_stack_size)
{
put_instruction_ (Ipushcaf);
GenLabel (label);
FPrintF (OutFile," %d %d",a_stack_size,b_stack_size);
}
void GenFillCaf (Label label,int a_stack_size,int b_stack_size)
{
put_instruction_ (Ifillcaf);
GenLabel (label);
FPrintF (OutFile," %d %d",a_stack_size,b_stack_size);
}
void GenCaf (Label label,int a_stack_size,int b_stack_size)
{
put_directive_ (Dcaf);
GenLabel (label);
FPrintF (OutFile," %d %d",a_stack_size,b_stack_size);
}
void GenPB (char *function_name)
{
put_directive_ (Dpb);
FPrintF (OutFile,"\"%s\"",function_name);
}
void GenPB_with_line_number (char *function_name,int line_number)
{
put_directive_ (Dpb);
FPrintF (OutFile,"\"%s[line:%d]\"",function_name,line_number);
}
void GenPD (void)
{
put_directive (Dpd);
}
void GenPN (void)
{
put_directive (Dpn);
}
void GenPL (void)
{
put_directive (Dpl);
}
void GenPLD (void)
{
put_directive (Dpld);
}
void GenPT (void)
{
put_directive (Dpt);
}
void GenPE (void)
{
put_directive (Dpe);
}
void GenKeep (int a_offset1,int a_offset2)
{
put_directive_ (Dkeep);
FPrintF (OutFile,"%d %d",a_offset1,a_offset2);
}
#if IMPORT_OBJ_AND_LIB
void GenImpObj (char *obj_name)
{
put_directive_ ("impobj");
FPrintF (OutFile,"%s",obj_name);
}
void GenImpLib (char *lib_name)
{
put_directive_ ("implib");
FPrintF (OutFile,"%s",lib_name);
}
#endif
void InitInstructions (void)
{
ABCFileName = NULL;
SetUnaryState (& ApplyState, StrictRedirection, UnknownObj);
ApplyLabel = NULL;
}