instructions.c 94.7 KB
Newer Older
clean's avatar
clean committed
1 2 3 4 5 6
/*
	(Concurrent) Clean Compiler: ABC instructions
	Authors:  Sjaak Smetsers & John van Groningen
*/

#include "compiledefines.h"
7
#include "comsupport.h"
clean's avatar
clean committed
8 9 10 11 12 13 14 15 16 17 18 19 20 21 22

#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"

John van Groningen's avatar
John van Groningen committed
23 24
#define for_l(v,l,n) for(v=(l);v!=NULL;v=v->n)

clean's avatar
clean committed
25 26 27 28 29 30
#define BINARY_ABC 0
#undef MEMORY_PROFILING_WITH_N_STRING

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

31 32 33 34 35
void PutIOutFile (long i)
{
	FPrintF (OutFile,"%ld",i);
}

clean's avatar
clean committed
36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53
static void error_in_function (char *m)
{
	ErrorInCompiler ("instructions.c",m,"");
}

#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
John van Groningen's avatar
John van Groningen committed
54
#define N_DoFusion				9
55
#define N_Do64BitArch			10
56
#define N_Dynamics				11
57
#define N_DoGenericFusion		12
clean's avatar
clean committed
58

John van Groningen's avatar
John van Groningen committed
59
#define MINIMUM_N_OPTIONS 9
60
#define N_OPTIONS 13
John van Groningen's avatar
John van Groningen committed
61 62

static void ConvertOptionsToString (char *optstring)
clean's avatar
clean committed
63 64 65 66 67 68 69 70 71 72 73 74 75 76 77
{
	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';
78

79
	if (DoFusion || ObjectSizes[RealObj]!=2 || Dynamics || DoGenericFusion){
80 81
		optstring[N_DoFusion] = DoFusion ? '1' : '0';
		optstring[N_Do64BitArch] = ObjectSizes[RealObj]!=2 ? '1' : '0';
82
		optstring[N_Dynamics] = Dynamics ? '1' : '0';
83
		optstring[N_DoGenericFusion] = DoGenericFusion ? '1' : '0';
John van Groningen's avatar
John van Groningen committed
84 85 86
		optstring[N_OPTIONS]='\0';
	} else
		optstring[MINIMUM_N_OPTIONS]='\0';
clean's avatar
clean committed
87 88 89 90 91 92 93
}

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

#define EA_PREFIX "ea"
94
#define EU_PREFIX "eu"
clean's avatar
clean committed
95 96 97 98 99 100 101 102 103 104 105 106 107 108
#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)
{
109
	OutFile = FOpen (fname, "w");
clean's avatar
clean committed
110 111

	if (OutFile!=NULL){
112
#if defined (POWER)
clean's avatar
clean committed
113 114 115 116 117 118 119 120 121 122 123
		setvbuf ((FILE*) OutFile, NULL, _IOFBF, 8192);
#endif
		OpenedFile = OutFile;
		ABCFileName = fname;
		return True;
	} else
		return False;
}

void WriteLastNewlineToABCFile (void)
{
124
	PutCOutFile ('\n');
clean's avatar
clean committed
125 126 127 128 129
}

void CloseABCFile (char *fname)
{
	if (OutFile){
130
		if (FClose (OutFile) != 0){
clean's avatar
clean committed
131 132 133
			CompilerError = True;
			CurrentLine = 0;
			
134
			StaticMessage_s_s (True, "<open file>", "Write error (disk full?)");
clean's avatar
clean committed
135 136
		}
		if (CompilerError)
137
			FDelete (fname);
clean's avatar
clean committed
138 139 140 141 142 143 144 145 146 147 148 149
		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)));
}

150
static void put_label_module_prefix_name (char *module_name,char *prefix,char *name)
151 152 153 154
{
	PutSOutFile ("e_");
	PutSOutFile (module_name);
	PutCOutFile ('_');
155 156
	PutSOutFile (prefix);
	PutSOutFile (name);
157 158
}

159
static void put_space_label_module_prefix_name (char *module_name,char *prefix,char *name)
160 161 162 163
{
	PutSOutFile (" e_");
	PutSOutFile (module_name);
	PutCOutFile ('_');
164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252
	PutSOutFile (prefix);
	PutSOutFile (name);
}

static void put_space_label_module_constructor_r_name (char *module_name,char *name)
{
	PutSOutFile (" e_");
	PutSOutFile (module_name);
	PutSOutFile ("_" CONSTRUCTOR_R_PREFIX);
	PutSOutFile (name);
}

static void put_space_label_module_d_name (char *module_name,char *name)
{
	PutSOutFile (" e_");
	PutSOutFile (module_name);
	PutSOutFile ("_" D_PREFIX);
	PutSOutFile (name);
}

static void put_space_label_module_ea_name (char *module_name,char *name)
{
	PutSOutFile (" e_");
	PutSOutFile (module_name);
	PutSOutFile ("_" EA_PREFIX);
	PutSOutFile (name);
}

static void put_space_label_module_eu_name (char *module_name,char *name)
{
	PutSOutFile (" e_");
	PutSOutFile (module_name);
	PutSOutFile ("_" EU_PREFIX);
	PutSOutFile (name);
}

static void put_space_label_module_l_name (char *module_name,char *name)
{
	PutSOutFile (" e_");
	PutSOutFile (module_name);
	PutSOutFile ("_" L_PREFIX);
	PutSOutFile (name);
}

static void put_space_label_module_n_name (char *module_name,char *name)
{
	PutSOutFile (" e_");
	PutSOutFile (module_name);
	PutSOutFile ("_" N_PREFIX);
	PutSOutFile (name);
}

static void put_space_label_module_r_name (char *module_name,char *name)
{
	PutSOutFile (" e_");
	PutSOutFile (module_name);
	PutSOutFile ("_" R_PREFIX);
	PutSOutFile (name);
}

static void put_space_label_module_record_d_name (char *module_name,char *name)
{
	PutSOutFile (" e_");
	PutSOutFile (module_name);
	PutSOutFile ("_" RECORD_D_PREFIX);
	PutSOutFile (name);
}

static void put_space_label_module_record_n_name (char *module_name,char *name)
{
	PutSOutFile (" e_");
	PutSOutFile (module_name);
	PutSOutFile ("_" RECORD_N_PREFIX);
	PutSOutFile (name);
}

static void put_space_label_module_s_name (char *module_name,char *name)
{
	PutSOutFile (" e_");
	PutSOutFile (module_name);
	PutSOutFile ("_" S_PREFIX);
	PutSOutFile (name);
}

static void put_space_quoted_string (char *s)
{
	PutSOutFile (" \"");
	PutSOutFile (s);
	PutCOutFile ('\"');
253 254
}

255 256 257 258 259 260 261 262 263 264 265 266
static void Put_SOutFile (char *s)
{
	PutCOutFile (' ');
	PutSOutFile (s);
}

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

267
static void PutSUOutFile (char *s1,unsigned int u)
268 269 270 271 272
{
	PutSOutFile (s1);
	PutIOutFile ((int)u);
}

273
static void PutSdotSOutFile (char *s1,char *s2)
274 275 276
{
	PutSOutFile (s1);
	PutCOutFile ('.');
277
	PutSOutFile (s2);
278 279
}

280
static void PutSdotUOutFile (char *s1,unsigned int u)
281 282
{
	PutSOutFile (s1);
283
	PutCOutFile ('.');
284 285 286
	PutIOutFile ((int)u);
}

287 288 289 290 291 292 293 294
static void PutSSdotDOutFile (char *s1,char *s2,int i)
{
	PutSOutFile (s1);
	PutSOutFile (s2);
	PutCOutFile ('.');
	PutIOutFile (i);
}

295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310
static void PutSSdotSOutFile (char *s1,char *s2,char *s3)
{
	PutSOutFile (s1);
	PutSOutFile (s2);
	PutCOutFile ('.');
	PutSOutFile (s3);
}

static void PutSSdotUOutFile (char *s1,char *s2,unsigned int u)
{
	PutSOutFile (s1);
	PutSOutFile (s2);
	PutCOutFile ('.');
	PutIOutFile ((int)u);
}

311 312 313 314 315 316 317 318 319 320 321 322
static void PutdotSOutFile (char *s)
{
	PutCOutFile ('.');
	PutSOutFile (s);
}

static void PutdotUOutFile (unsigned int u)
{
	PutCOutFile ('.');
	PutIOutFile ((int)u);
}

clean's avatar
clean committed
323 324 325 326 327 328 329 330 331
static void GenLabel (Label label)
{
	if (label->lab_issymbol){
		SymbDef def;
		char *module_name;

		def=label->lab_symbol;
		module_name = label->lab_mod;
		
332 333 334
		if (module_name!=NULL)
			put_label_module_prefix_name (module_name,label->lab_pref,def->sdef_name);
		else if (DoDebug){
clean's avatar
clean committed
335
			if (def->sdef_kind==IMPRULE)
336
				PutSSdotUOutFile (label->lab_pref,def->sdef_name,def->sdef_number);
clean's avatar
clean committed
337
			else
338
				PutSSOutFile (label->lab_pref,def->sdef_name);
clean's avatar
clean committed
339
		} else if (def->sdef_number==0)
340
			PutSSOutFile (label->lab_pref,def->sdef_name);
clean's avatar
clean committed
341
		else if (label->lab_pref[0] == '\0')
342
			PutSUOutFile (LOCAL_D_PREFIX,def->sdef_number);
clean's avatar
clean committed
343
		else
344
			PutSUOutFile (label->lab_pref,def->sdef_number);
clean's avatar
clean committed
345
	} else {
346 347
		PutSOutFile (label->lab_pref);
		PutSOutFile (label->lab_name);
clean's avatar
clean committed
348 349
	}
	if (label->lab_post!=0)
350
		PutdotUOutFile (label->lab_post);
clean's avatar
clean committed
351 352
}

353 354 355 356 357 358 359 360 361
static void GenDescriptorOrNodeEntryLabel (Label label)
{
	if (label->lab_issymbol){
		SymbDef def;
		char *module_name;

		def=label->lab_symbol;
		module_name = label->lab_mod;
		
362 363 364 365
		if (module_name!=NULL)
			put_label_module_prefix_name (module_name,label->lab_pref,def->sdef_name);
		else if (ExportLocalLabels){
			put_label_module_prefix_name (CurrentModule,label->lab_pref,def->sdef_name);
366
			if (def->sdef_kind==IMPRULE)
367
				PutdotUOutFile (def->sdef_number);
368 369
		} else if (DoDebug){
			if (def->sdef_kind==IMPRULE)
370
				PutSSdotUOutFile (label->lab_pref,def->sdef_name,def->sdef_number);
371
			else
372
				PutSSOutFile (label->lab_pref,def->sdef_name);
373
		} else if (def->sdef_number==0)
374
			PutSSOutFile (label->lab_pref,def->sdef_name);
375
		else if (label->lab_pref[0] == '\0')
376
			PutSUOutFile (LOCAL_D_PREFIX,def->sdef_number);
377
		else
378
			PutSUOutFile (label->lab_pref,def->sdef_number);
379
	} else {
380 381
		PutSOutFile (label->lab_pref);
		PutSOutFile (label->lab_name);
382 383
	}
	if (label->lab_post!=0)
384
		PutdotUOutFile (label->lab_post);
385 386
}

clean's avatar
clean committed
387 388 389 390
#if !BINARY_ABC

#define put_instructionb(a) put_instruction(I##a)
#define put_instruction_b(a) put_instruction_(I##a)
391
#define put_directiveb(a) put_directive(D##a)
clean's avatar
clean committed
392
#define put_directive_b(a) put_directive_(D##a)
393 394
#define put_arguments_i_b(i1) FPrintF (OutFile," %s",(i1))
#define put_arguments_in_b(i1,n1) FPrintF (OutFile," %s %d",(i1),(n1))
395 396
#define put_argumentsn_b(n1) FPrintF (OutFile,"%d",(n1))
#define put_argumentsnn_b(n1,n2) FPrintF (OutFile,"%d %d",(n1),(n2))
397 398 399
#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))
400
#define put_argumentsn__b(n1) FPrintF (OutFile,"%d ",(n1))
401
#define put_arguments_nn__b(n1,n2) FPrintF (OutFile," %d %d ",(n1),(n2))
402 403 404
#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))
clean's avatar
clean committed
405 406 407 408 409 410 411 412 413 414 415

#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)
416
#define put_directiveb(a) if (DoDebug) put_directive(D##a); else put_instruction_code(C##a)
clean's avatar
clean committed
417 418 419 420 421
#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)){
422
		PutCOutFile (128+(n & 127));
clean's avatar
clean committed
423 424 425
		n=n>>7;
	}

426
	PutCOutFile (n+64);
clean's avatar
clean committed
427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456
}

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

457
static void put_arguments_i_b (char *i1)
clean's avatar
clean committed
458
{
459 460
	if (DoDebug){
		PutCOutFile (' ');
461
		PutSOutFile (i1);
462
	} else
clean's avatar
clean committed
463 464 465
		put_n (integer_string_to_integer (i1));
}

466
static void put_arguments_in_b (char *i1,long n1)
clean's avatar
clean committed
467 468
{
	if (DoDebug)
469
		FPrintF (OutFile," %s %d",(i1),(n1));
clean's avatar
clean committed
470 471 472 473 474 475
	else {
		put_n (integer_string_to_integer (i1));
		put_n (n1);
	}
}

476
static void put_argumentsn_b (long n1)
clean's avatar
clean committed
477 478 479 480 481 482 483
{
	if (DoDebug)
		FPrintF (OutFile,"%d",(n1));
	else
		put_n (n1);
}

484
static void put_argumentsnn_b (long n1,long n2)
clean's avatar
clean committed
485 486 487 488 489 490 491 492 493
{
	if (DoDebug)
		FPrintF (OutFile,"%d %d",(n1),(n2));
	else {
		put_n (n1);
		put_n (n2);
	}
}

494
static void put_arguments_nnn_b (long n1,long n2,long n3)
clean's avatar
clean committed
495 496
{
	if (DoDebug)
497
		FPrintF (OutFile," %d %d %d",(n1),(n2),(n3));
clean's avatar
clean committed
498 499 500 501 502 503 504
	else {
		put_n (n1);
		put_n (n2);
		put_n (n3);
	}
}

505
static void put_arguments_nnnn_b (long n1,long n2,long n3,long n4)
clean's avatar
clean committed
506 507
{
	if (DoDebug)	
508
		FPrintF (OutFile," %d %d %d %d",(n1),(n2),(n3),(n4));
clean's avatar
clean committed
509 510 511 512 513 514 515 516
	else {
		put_n (n1);
		put_n (n2);
		put_n (n3);
		put_n (n4);
	}
}

517
static void put_arguments_nnnnn_b (long n1,long n2,long n3,long n4,long n5)
clean's avatar
clean committed
518 519
{
	if (DoDebug)
520
		FPrintF (OutFile," %d %d %d %d %d",(n1),(n2),(n3),(n4),(n5));
clean's avatar
clean committed
521 522 523 524 525 526 527 528 529
	else {
		put_n (n1);
		put_n (n2);
		put_n (n3);
		put_n (n4);
		put_n (n5);
	}
}

530
static void put_argumentsn__b (long n1)
clean's avatar
clean committed
531 532 533 534 535 536 537
{
	if (DoDebug)
		FPrintF (OutFile,"%d ",(n1));
	else
		put_n (n1);
}

538
static void put_arguments_n_b (long n1)
clean's avatar
clean committed
539 540 541 542
{
	if (DoDebug)
		FPrintF (OutFile," %d",(n1));
	else {
543
		PutCOutFile (' ',OutFile);
clean's avatar
clean committed
544 545 546 547
		put_n (n1);
	}
}

548
static void put_arguments_n__b (long n1)
clean's avatar
clean committed
549 550 551 552
{
	if (DoDebug)
		FPrintF (OutFile," %d ",(n1));
	else {
553
		PutCOutFile (' ',OutFile);
clean's avatar
clean committed
554 555 556 557
		put_n (n1);
	}
}

558
static void put_arguments_nn__b (long n1,long n2)
clean's avatar
clean committed
559 560
{
	if (DoDebug)
561
		FPrintF (OutFile," %d %d ",(n1),(n2));
clean's avatar
clean committed
562 563 564 565 566 567
	else {
		put_n (n1);
		put_n (n2);
	}
}

568
static void put_arguments_nn_b (long n1,long n2)
clean's avatar
clean committed
569 570 571 572
{
	if (DoDebug)
		FPrintF (OutFile," %d %d",(n1),(n2));
	else {
573
		PutCOutFile (' ',OutFile);
clean's avatar
clean committed
574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639
		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,
640
	Cimpmod,
clean's avatar
clean committed
641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678
	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"

679 680
#define InotB "notB"

clean's avatar
clean committed
681 682 683 684
#define IpushB "pushB"
#define IpushI "pushI"
#define IpushC "pushC"
#define IpushR "pushR"
685 686
#define IpushZR "pushZR"
#define IpushZ "pushZ"
clean's avatar
clean committed
687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710

#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"
711
#define Ipush_r_arg_u "push_r_arg_u"
clean's avatar
clean committed
712 713 714 715 716 717 718 719 720 721 722 723 724 725 726
#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"
727
#define Ifill3 "fill3"
clean's avatar
clean committed
728 729 730 731 732 733 734 735 736 737 738

#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"

739
#define Ibuildhr "buildhr"
clean's avatar
clean committed
740 741 742 743 744 745 746 747
#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"
748
#define Ijsr_ap "jsr_ap"
749
#define Ijsr_i "jsr_i"
clean's avatar
clean committed
750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780

#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"
781
#define Ijmp_ap "jmp_ap"
782
#define Ijmp_ap_upd "jmp_ap_upd"
783 784
#define Ijmp_i "jmp_i"
#define Ijmp_not_eqZ "jmp_not_eqZ"
785
#define Ijmp_upd "jmp_upd"
clean's avatar
clean committed
786 787 788 789 790 791 792 793 794 795 796 797

#define Ihalt "halt"

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

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

static void put_instruction (char *instruction)
{
798 799
	PutCOutFile ('\n');
	PutCOutFile ('\t');
800
	PutSOutFile (instruction);
clean's avatar
clean committed
801 802 803 804
}

static void put_instruction_ (char *instruction)
{
805 806
	PutCOutFile ('\n');
	PutCOutFile ('\t');
807
	PutSOutFile (instruction);
808
	PutCOutFile (' ');
clean's avatar
clean committed
809 810 811 812
}

static void put_instruction_code (int instruction_code)
{
813
	PutCOutFile (instruction_code);
clean's avatar
clean committed
814 815
}

816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849
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;
		}
	}
}

850
#define Da "a"
851
#define Dai "ai"
clean's avatar
clean committed
852 853 854 855 856
#define Dkeep "keep"
#define Dd "d"
#define Do "o"
#define Dimpdesc "impdesc"
#define Dimplab "implab"
857
#define Dimpmod "impmod"
clean's avatar
clean committed
858 859 860 861 862
#define Dexport "export"
#define Dn "n"
#define Dnu "nu"
#define Dn_string "n_string"
#define Ddesc "desc"
863
#define Ddesc0 "desc0"
clean's avatar
clean committed
864
#define Ddescn "descn"
865
#define Ddescs "descs"
clean's avatar
clean committed
866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885
#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)
{
886 887
	PutCOutFile ('\n');
	PutCOutFile ('.');
888
	PutSOutFile (directive);
clean's avatar
clean committed
889 890 891 892
}

static void put_directive_ (char *directive)
{
893 894
	PutCOutFile ('\n');
	PutCOutFile ('.');
895
	PutSOutFile (directive);
896
	PutCOutFile (' ');
clean's avatar
clean committed
897 898
}

899
static void put_first_directive (char *directive)
clean's avatar
clean committed
900
{
901
	PutCOutFile ('.');
902
	PutSOutFile (directive);
clean's avatar
clean committed
903 904 905 906 907 908 909 910
}

void BuildBasicFromB (ObjectKind kind,int b_offset)
{
	switch (kind){
		case IntObj:
		case ProcIdObj:
		case RedIdObj:
911
			put_instructionb (buildI_b); break;
clean's avatar
clean committed
912
		case BoolObj:
913
			put_instructionb (buildB_b); break;
clean's avatar
clean committed
914
		case CharObj:
915
			put_instructionb (buildC_b); break;
clean's avatar
clean committed
916
		case RealObj:
917
			put_instructionb (buildR_b); break;
clean's avatar
clean committed
918
		case FileObj:
919
			put_instructionb (buildF_b); break;
clean's avatar
clean committed
920 921 922 923 924
		default:
			error_in_function ("BuildBasicFromB");
			return;
	}

925
	put_arguments_n_b (b_offset);
clean's avatar
clean committed
926 927 928 929 930 931 932 933 934
}

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				*/
935
			put_instructionb (fillI_b); break;
clean's avatar
clean committed
936
		case BoolObj:
937
			put_instructionb (fillB_b); break;
clean's avatar
clean committed
938
		case CharObj:
939
			put_instructionb (fillC_b); break;
clean's avatar
clean committed
940
		case RealObj:
941
			put_instructionb (fillR_b); break;
clean's avatar
clean committed
942
		case FileObj:
943
			put_instructionb (fillF_b); break;
clean's avatar
clean committed
944 945 946 947
		default:
			error_in_function ("FillBasicFromB");
			return;
	}
948
	put_arguments_nn_b (boffs,aoffs);
clean's avatar
clean committed
949 950
	TreatWaitListAfterFill (aoffs, fkind);
}
John van Groningen's avatar
John van Groningen committed
951

clean's avatar
clean committed
952 953 954 955
void BuildBasic (ObjectKind obj,SymbValue val)
{
	switch (obj){
		case IntObj:
956 957
			put_instructionb (buildI);
			put_arguments_i_b (val.val_int);
clean's avatar
clean committed
958 959 960
			break;
		case BoolObj:
			put_instruction_ (IbuildB);
961
			PutSOutFile (val.val_bool ? "TRUE" : "FALSE");
clean's avatar
clean committed
962 963
			break;
		case CharObj:
964 965
			put_instruction (IbuildC);
			Put_SOutFile (val.val_char);
clean's avatar
clean committed
966 967
			break;
		case RealObj:
968 969
			put_instruction (IbuildR);
			Put_SOutFile (val.val_real);
clean's avatar
clean committed
970 971 972 973 974 975 976 977 978 979 980 981
			break;
		default:
			error_in_function ("BuildBasic");
			return;
	}
}

void FillBasic (ObjectKind obj, SymbValue val, int offset, FillKind fkind)
{
	TreatWaitListBeforeFill (offset, fkind);
	switch (obj){
		case IntObj:
982 983
			put_instructionb (fillI);
			put_arguments_in_b (val.val_int,offset);
clean's avatar
clean committed
984 985
			break;
		case BoolObj:
986 987 988
			put_instruction (IfillB);
			PutSOutFile (val.val_bool ? " TRUE" : " FALSE");
			put_arguments_n_b (offset);
clean's avatar
clean committed
989 990
			break;
		case CharObj:
991 992 993
			put_instruction (IfillC);
			Put_SOutFile (val.val_char);
			put_arguments_n_b (offset);
clean's avatar
clean committed
994 995
			break;
		case RealObj:
996 997 998
			put_instruction (IfillR);
			Put_SOutFile (val.val_real);
			put_arguments_n_b (offset);
clean's avatar
clean committed
999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010
			break;
		default:
			error_in_function ("FillBasic");
			return;
	}
	TreatWaitListAfterFill (offset, fkind);
}

void IsBasic (ObjectKind obj, SymbValue val, int offset)
{
	switch (obj){
		case IntObj:
1011 1012 1013
			put_instructionb (eqI_a);
			put_arguments_in_b (val.val_int,offset);
			return;
clean's avatar
clean committed
1014
		case BoolObj:
1015 1016
			put_instruction (IeqB_a);
			PutSOutFile (val.val_bool ? " TRUE" : " FALSE");
clean's avatar
clean committed
1017 1018
			break;
		case CharObj:
1019 1020 1021
			put_instruction (IeqC_a);
			Put_SOutFile (val.val_char);
			break;
clean's avatar
clean committed
1022
		case RealObj:
1023 1024 1025
			put_instruction (IeqR_a);
			Put_SOutFile (val.val_real);
			break;
clean's avatar
clean committed
1026 1027 1028 1029
		default:
			error_in_function ("IsBasic");
			return;
	}
1030
	put_arguments_n_b (offset);
clean's avatar
clean committed
1031 1032 1033 1034 1035
}

void IsString (SymbValue val)
{
	put_instruction_ (IeqAC_a);
1036
	PutSOutFile (val.val_string);
clean's avatar
clean committed
1037 1038 1039 1040 1041 1042
}

void PushBasic (ObjectKind obj, SymbValue val)
{
	switch (obj){
		case IntObj:
1043 1044
			put_instructionb (pushI);
			put_arguments_i_b (val.val_int);
clean's avatar
clean committed
1045 1046 1047
			break;
		case BoolObj:
			put_instruction_ (IpushB);
1048
			PutSOutFile (val.val_bool ? "TRUE" : "FALSE");
clean's avatar
clean committed
1049 1050
			break;
		case CharObj:
1051 1052
			put_instruction (IpushC);
			Put_SOutFile (val.val_char);
1053
			break;
clean's avatar
clean committed
1054 1055
		case RealObj:
			put_instruction_ (IpushR);
1056 1057
			PutSOutFile (val.val_real);
			break;
clean's avatar
clean committed
1058 1059 1060 1061 1062 1063 1064 1065
		default:
			error_in_function ("PushBasic");
			return;
	}
}

void GenPushReducerId (int i)
{
1066 1067
	put_instructionb (pushI);
	put_arguments_n_b (i);
clean's avatar
clean committed
1068 1069 1070 1071
}

void GenPushArgNr (int argnr)
{
1072 1073
	put_instructionb (pushI);
	put_arguments_n_b (argnr);
clean's avatar
clean committed
1074 1075 1076 1077 1078 1079
}

void EqBasic (ObjectKind obj, SymbValue val, int offset)
{
	switch (obj){
		case IntObj:
1080 1081 1082
			put_instructionb (eqI_b);
			put_arguments_in_b (val.val_int,offset);
			return;
clean's avatar
clean committed
1083
		case BoolObj:
1084 1085
			put_instruction (IeqB_b);
			PutSOutFile (val.val_bool ? " TRUE" : " FALSE");
clean's avatar
clean committed
1086 1087
			break;
		case CharObj:
1088 1089
			put_instruction (IeqC_b);
			Put_SOutFile (val.val_char);
1090
			break;
clean's avatar
clean committed
1091
		case RealObj:
1092 1093
			put_instruction (IeqR_b);
			Put_SOutFile (val.val_real);
1094
			break;
clean's avatar
clean committed
1095 1096 1097 1098
		default:
			error_in_function ("EqBasic");
			return;
	}
1099
	put_arguments_n_b (offset);
clean's avatar
clean committed
1100 1101
}

1102 1103 1104 1105 1106
void GenNotB (void)
{
	put_instruction (InotB);
}

clean's avatar
clean committed
1107 1108 1109 1110 1111 1112
void PushBasicFromAOnB (ObjectKind kind,int offset)
{
	switch (kind){
		case IntObj:
		case ProcIdObj:
		case RedIdObj:
1113
			put_instructionb (pushI_a);
clean's avatar
clean committed
1114 1115
			break;
		case BoolObj:
1116
			put_instructionb (pushB_a);
clean's avatar
clean committed
1117 1118
			break;
		case CharObj:
1119
			put_instructionb (pushC_a);
clean's avatar
clean committed
1120 1121
			break;
		case RealObj:
1122
			put_instructionb (pushR_a);
clean's avatar
clean committed
1123 1124
			break;
		case FileObj:
1125
			put_instructionb (pushF_a);
clean's avatar
clean committed
1126 1127 1128 1129 1130
			break;
		default:
			error_in_function ("PushBasicFromAOnB");
			return;
	}
1131
	put_arguments_n_b (offset);
clean's avatar
clean committed
1132 1133 1134 1135
}

void GenPushD_a (int a_offset)
{
1136 1137
	put_instruction (IpushD_a);
	put_arguments_n_b (a_offset);
clean's avatar
clean committed
1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209
}
	
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'.
*/

1210
static char BElems[] = BASIC_ELEMS_STRING;
clean's avatar
clean committed
1211 1212 1213 1214 1215

static void GenBStackElems (StateS state)
{
	if (IsSimpleState (state)){
		if (state.state_kind == OnB)
1216
			PutCOutFile (BElems [(int) state.state_object]);			
clean's avatar
clean committed
1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242
	} 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)
1243
			PutCOutFile (BElems [(int) state.state_object]);
clean's avatar
clean committed
1244
		else
1245
			PutCOutFile ('a');
clean's avatar
clean committed
1246 1247 1248 1249 1250 1251
	} else {
		int arity;
		States argstates;
		
		switch (state.state_type){
			case TupleState:
1252
				argstates = state.state_tuple_arguments;			
1253
				PutCOutFile ('(');
1254 1255 1256
				if (state.state_arity>0){
					GenABStackElems (argstates[0]);
					for (arity=1; arity < state.state_arity; arity++){
1257
						PutCOutFile (',');
1258 1259 1260
						GenABStackElems (argstates[arity]);
					}
				}
1261
				PutCOutFile (')');
clean's avatar
clean committed
1262 1263 1264
				break;
			case RecordState:
				argstates = state.state_record_arguments;
1265
				PutCOutFile ('(');
1266 1267
				for (arity=0; arity < state.state_arity; arity++)
					GenABStackElems (argstates[arity]);
1268
				PutCOutFile (')');
1269
				return;
clean's avatar
clean committed
1270
			case ArrayState:
1271
				PutCOutFile ('a');
clean's avatar
clean committed
1272 1273 1274 1275 1276 1277 1278 1279
				return;
			default:
				error_in_function ("GenABStackElems");
				return;
		}
	}
}

1280 1281 1282 1283
static void GenABStackElemsForRecordDesc (StateS state)
{
	if (IsSimpleState (state)){
		if (state.state_kind == OnB)
1284
			PutCOutFile (BElems [(int) state.state_object]);
1285
		else
1286
			PutCOutFile ('a');
1287 1288 1289 1290 1291 1292 1293
	} else {
		int arity;
		States argstates;
		
		switch (state.state_type){
			case TupleState:
				argstates = state.state_tuple_arguments;			
1294
				PutCOutFile ('(');