instructions.c 93.5 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
}

387
#if BINARY_ABC
clean's avatar
clean committed
388 389 390
static void put_n (long n)
{
	while (!(n>=-64 && n<=63)){
391
		PutCOutFile (128+(n & 127));
clean's avatar
clean committed
392 393 394
		n=n>>7;
	}

395
	PutCOutFile (n+64);
clean's avatar
clean committed
396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424
}

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;
}
425
#endif
clean's avatar
clean committed
426

427
static void put_arguments_i_b (char *i1)
clean's avatar
clean committed
428
{
429 430
#if BINARY_ABC
	if (!DoDebug){
clean's avatar
clean committed
431
		put_n (integer_string_to_integer (i1));
432 433 434 435 436
		return;
	}
#endif
	PutCOutFile (' ');
	PutSOutFile (i1);
clean's avatar
clean committed
437 438
}

439
static void put_arguments_in_b (char *i1,long n1)
clean's avatar
clean committed
440
{
441 442
#if BINARY_ABC
	if (!DoDebug){
clean's avatar
clean committed
443 444
		put_n (integer_string_to_integer (i1));
		put_n (n1);
445
		return;
clean's avatar
clean committed
446
	}
447 448 449 450 451
#endif
	PutCOutFile (' ');
	PutSOutFile (i1);
	PutCOutFile (' ');
	PutIOutFile (n1);
clean's avatar
clean committed
452 453
}

454
static void put_arguments_n_b (long n1)
clean's avatar
clean committed
455
{
456 457
#if BINARY_ABC
	if (!DoDebug){
clean's avatar
clean committed
458
		put_n (n1);
459 460 461 462 463
		return;
	}
#endif
	PutCOutFile (' ');
	PutIOutFile (n1);
clean's avatar
clean committed
464 465
}

466
static void put_arguments_nn_b (long n1,long n2)
clean's avatar
clean committed
467
{
468 469
#if BINARY_ABC
	if (!DoDebug){
clean's avatar
clean committed
470 471
		put_n (n1);
		put_n (n2);
472
		return;
clean's avatar
clean committed
473
	}
474 475 476 477 478
#endif
	PutCOutFile (' ');
	PutIOutFile (n1);
	PutCOutFile (' ');
	PutIOutFile (n2);
clean's avatar
clean committed
479 480
}

481
static void put_arguments_nnn_b (long n1,long n2,long n3)
clean's avatar
clean committed
482
{
483 484
#if BINARY_ABC
	if (!DoDebug){
clean's avatar
clean committed
485 486 487
		put_n (n1);
		put_n (n2);
		put_n (n3);
488
		return;
clean's avatar
clean committed
489
	}
490 491 492 493 494 495 496
#endif
	PutCOutFile (' ');
	PutIOutFile (n1);
	PutCOutFile (' ');
	PutIOutFile (n2);
	PutCOutFile (' ');
	PutIOutFile (n3);
clean's avatar
clean committed
497 498
}

499
static void put_arguments_nnnn_b (long n1,long n2,long n3,long n4)
clean's avatar
clean committed
500
{
501 502
#if BINARY_ABC
	if (!DoDebug){
clean's avatar
clean committed
503 504 505 506
		put_n (n1);
		put_n (n2);
		put_n (n3);
		put_n (n4);
507
		return;
clean's avatar
clean committed
508
	}
509 510 511 512 513 514 515 516 517
#endif
	PutCOutFile (' ');
	PutIOutFile (n1);
	PutCOutFile (' ');
	PutIOutFile (n2);
	PutCOutFile (' ');
	PutIOutFile (n3);
	PutCOutFile (' ');
	PutIOutFile (n4);
clean's avatar
clean committed
518 519
}

520
static void put_arguments_nnnnn_b (long n1,long n2,long n3,long n4,long n5)
clean's avatar
clean committed
521
{
522 523
#if BINARY_ABC
	if (!DoDebug){
clean's avatar
clean committed
524 525 526 527 528
		put_n (n1);
		put_n (n2);
		put_n (n3);
		put_n (n4);
		put_n (n5);
529
		return;
clean's avatar
clean committed
530
	}
531 532 533 534 535 536 537 538 539 540 541
#endif
	PutCOutFile (' ');
	PutIOutFile (n1);
	PutCOutFile (' ');
	PutIOutFile (n2);
	PutCOutFile (' ');
	PutIOutFile (n3);
	PutCOutFile (' ');
	PutIOutFile (n4);
	PutCOutFile (' ');
	PutIOutFile (n5);
clean's avatar
clean committed
542 543
}

544
#if !BINARY_ABC
clean's avatar
clean committed
545

546 547 548 549
#define put_instructionb(a) put_instruction(I##a)
#define put_instruction_b(a) put_instruction_(I##a)
#define put_directiveb(a) put_directive(D##a)
#define put_directive_b(a) put_directive_(D##a)
clean's avatar
clean committed
550

551
#else
clean's avatar
clean committed
552

553 554 555 556
#define put_instructionb(a) if (DoDebug) put_instruction(I##a); else put_instruction_code(C##a)
#define put_instruction_b(a) if (DoDebug) put_instruction_(I##a); else put_instruction_code(C##a)
#define put_directiveb(a) if (DoDebug) put_directive(D##a); else put_instruction_code(C##a)
#define put_directive_b(a) if (DoDebug) put_directive_(D##a); else put_instruction_code(C##a)
clean's avatar
clean committed
557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 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

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,
619
	Cimpmod,
clean's avatar
clean committed
620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657
	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"

658 659
#define InotB "notB"

clean's avatar
clean committed
660 661 662 663
#define IpushB "pushB"
#define IpushI "pushI"
#define IpushC "pushC"
#define IpushR "pushR"
664 665
#define IpushZR "pushZR"
#define IpushZ "pushZ"
clean's avatar
clean committed
666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689

#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"
690
#define Ipush_r_arg_u "push_r_arg_u"
clean's avatar
clean committed
691 692 693 694 695 696 697 698 699 700 701 702 703 704 705
#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"
706
#define Ifill3 "fill3"
clean's avatar
clean committed
707 708 709 710 711 712 713 714 715 716 717

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

718
#define Ibuildhr "buildhr"
clean's avatar
clean committed
719 720 721 722 723 724 725 726
#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"
727
#define Ijsr_ap "jsr_ap"
728
#define Ijsr_i "jsr_i"
clean's avatar
clean committed
729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759

#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"
760
#define Ijmp_ap "jmp_ap"
761
#define Ijmp_ap_upd "jmp_ap_upd"
762 763
#define Ijmp_i "jmp_i"
#define Ijmp_not_eqZ "jmp_not_eqZ"
764
#define Ijmp_upd "jmp_upd"
clean's avatar
clean committed
765 766 767 768 769 770 771 772 773 774 775 776

#define Ihalt "halt"

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

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

static void put_instruction (char *instruction)
{
777 778
	PutCOutFile ('\n');
	PutCOutFile ('\t');
779
	PutSOutFile (instruction);
clean's avatar
clean committed
780 781 782 783
}

static void put_instruction_ (char *instruction)
{
784 785
	PutCOutFile ('\n');
	PutCOutFile ('\t');
786
	PutSOutFile (instruction);
787
	PutCOutFile (' ');
clean's avatar
clean committed
788 789 790 791
}

static void put_instruction_code (int instruction_code)
{
792
	PutCOutFile (instruction_code);
clean's avatar
clean committed
793 794
}

795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828
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;
		}
	}
}

829
#define Da "a"
830
#define Dai "ai"
clean's avatar
clean committed
831 832 833 834 835
#define Dkeep "keep"
#define Dd "d"
#define Do "o"
#define Dimpdesc "impdesc"
#define Dimplab "implab"
836
#define Dimpmod "impmod"
clean's avatar
clean committed
837 838 839 840 841
#define Dexport "export"
#define Dn "n"
#define Dnu "nu"
#define Dn_string "n_string"
#define Ddesc "desc"
842
#define Ddesc0 "desc0"
clean's avatar
clean committed
843
#define Ddescn "descn"
844
#define Ddescs "descs"
clean's avatar
clean committed
845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864
#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)
{
865 866
	PutCOutFile ('\n');
	PutCOutFile ('.');
867
	PutSOutFile (directive);
clean's avatar
clean committed
868 869 870 871
}

static void put_directive_ (char *directive)
{
872 873
	PutCOutFile ('\n');
	PutCOutFile ('.');
874
	PutSOutFile (directive);
875
	PutCOutFile (' ');
clean's avatar
clean committed
876 877
}

878
static void put_first_directive (char *directive)
clean's avatar
clean committed
879
{
880
	PutCOutFile ('.');
881
	PutSOutFile (directive);
clean's avatar
clean committed
882 883 884 885 886 887 888 889
}

void BuildBasicFromB (ObjectKind kind,int b_offset)
{
	switch (kind){
		case IntObj:
		case ProcIdObj:
		case RedIdObj:
890
			put_instructionb (buildI_b); break;
clean's avatar
clean committed
891
		case BoolObj:
892
			put_instructionb (buildB_b); break;
clean's avatar
clean committed
893
		case CharObj:
894
			put_instructionb (buildC_b); break;
clean's avatar
clean committed
895
		case RealObj:
896
			put_instructionb (buildR_b); break;
clean's avatar
clean committed
897
		case FileObj:
898
			put_instructionb (buildF_b); break;
clean's avatar
clean committed
899 900 901 902 903
		default:
			error_in_function ("BuildBasicFromB");
			return;
	}

904
	put_arguments_n_b (b_offset);
clean's avatar
clean committed
905 906 907 908 909 910 911 912 913
}

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				*/
914
			put_instructionb (fillI_b); break;
clean's avatar
clean committed
915
		case BoolObj:
916
			put_instructionb (fillB_b); break;
clean's avatar
clean committed
917
		case CharObj:
918
			put_instructionb (fillC_b); break;
clean's avatar
clean committed
919
		case RealObj:
920
			put_instructionb (fillR_b); break;
clean's avatar
clean committed
921
		case FileObj:
922
			put_instructionb (fillF_b); break;
clean's avatar
clean committed
923 924 925 926
		default:
			error_in_function ("FillBasicFromB");
			return;
	}
927
	put_arguments_nn_b (boffs,aoffs);
clean's avatar
clean committed
928 929
	TreatWaitListAfterFill (aoffs, fkind);
}
John van Groningen's avatar
John van Groningen committed
930

clean's avatar
clean committed
931 932 933 934
void BuildBasic (ObjectKind obj,SymbValue val)
{
	switch (obj){
		case IntObj:
935 936
			put_instructionb (buildI);
			put_arguments_i_b (val.val_int);
clean's avatar
clean committed
937 938 939
			break;
		case BoolObj:
			put_instruction_ (IbuildB);
940
			PutSOutFile (val.val_bool ? "TRUE" : "FALSE");
clean's avatar
clean committed
941 942
			break;
		case CharObj:
943 944
			put_instruction (IbuildC);
			Put_SOutFile (val.val_char);
clean's avatar
clean committed
945 946
			break;
		case RealObj:
947 948
			put_instruction (IbuildR);
			Put_SOutFile (val.val_real);
clean's avatar
clean committed
949 950 951 952 953 954 955 956 957 958 959 960
			break;
		default:
			error_in_function ("BuildBasic");
			return;
	}
}

void FillBasic (ObjectKind obj, SymbValue val, int offset, FillKind fkind)
{
	TreatWaitListBeforeFill (offset, fkind);
	switch (obj){
		case IntObj:
961 962
			put_instructionb (fillI);
			put_arguments_in_b (val.val_int,offset);
clean's avatar
clean committed
963 964
			break;
		case BoolObj:
965 966 967
			put_instruction (IfillB);
			PutSOutFile (val.val_bool ? " TRUE" : " FALSE");
			put_arguments_n_b (offset);
clean's avatar
clean committed
968 969
			break;
		case CharObj:
970 971 972
			put_instruction (IfillC);
			Put_SOutFile (val.val_char);
			put_arguments_n_b (offset);
clean's avatar
clean committed
973 974
			break;
		case RealObj:
975 976 977
			put_instruction (IfillR);
			Put_SOutFile (val.val_real);
			put_arguments_n_b (offset);
clean's avatar
clean committed
978 979 980 981 982 983 984 985 986 987 988 989
			break;
		default:
			error_in_function ("FillBasic");
			return;
	}
	TreatWaitListAfterFill (offset, fkind);
}

void IsBasic (ObjectKind obj, SymbValue val, int offset)
{
	switch (obj){
		case IntObj:
990 991 992
			put_instructionb (eqI_a);
			put_arguments_in_b (val.val_int,offset);
			return;
clean's avatar
clean committed
993
		case BoolObj:
994 995
			put_instruction (IeqB_a);
			PutSOutFile (val.val_bool ? " TRUE" : " FALSE");
clean's avatar
clean committed
996 997
			break;
		case CharObj:
998 999 1000
			put_instruction (IeqC_a);
			Put_SOutFile (val.val_char);
			break;
clean's avatar
clean committed
1001
		case RealObj:
1002 1003 1004
			put_instruction (IeqR_a);
			Put_SOutFile (val.val_real);
			break;
clean's avatar
clean committed
1005 1006 1007 1008
		default:
			error_in_function ("IsBasic");
			return;
	}
1009
	put_arguments_n_b (offset);
clean's avatar
clean committed
1010 1011 1012 1013 1014
}

void IsString (SymbValue val)
{
	put_instruction_ (IeqAC_a);
1015
	PutSOutFile (val.val_string);
clean's avatar
clean committed
1016 1017 1018 1019 1020 1021
}

void PushBasic (ObjectKind obj, SymbValue val)
{
	switch (obj){
		case IntObj:
1022 1023
			put_instructionb (pushI);
			put_arguments_i_b (val.val_int);
clean's avatar
clean committed
1024 1025 1026
			break;
		case BoolObj:
			put_instruction_ (IpushB);
1027
			PutSOutFile (val.val_bool ? "TRUE" : "FALSE");
clean's avatar
clean committed
1028 1029
			break;
		case CharObj:
1030 1031
			put_instruction (IpushC);
			Put_SOutFile (val.val_char);
1032
			break;
clean's avatar
clean committed
1033 1034
		case RealObj:
			put_instruction_ (IpushR);
1035 1036
			PutSOutFile (val.val_real);
			break;
clean's avatar
clean committed
1037 1038 1039 1040 1041 1042 1043 1044
		default:
			error_in_function ("PushBasic");
			return;
	}
}

void GenPushReducerId (int i)
{
1045 1046
	put_instructionb (pushI);
	put_arguments_n_b (i);
clean's avatar
clean committed
1047 1048 1049 1050
}

void GenPushArgNr (int argnr)
{
1051 1052
	put_instructionb (pushI);
	put_arguments_n_b (argnr);
clean's avatar
clean committed
1053 1054 1055 1056 1057 1058
}

void EqBasic (ObjectKind obj, SymbValue val, int offset)
{
	switch (obj){
		case IntObj:
1059 1060 1061
			put_instructionb (eqI_b);
			put_arguments_in_b (val.val_int,offset);
			return;
clean's avatar
clean committed
1062
		case BoolObj:
1063 1064
			put_instruction (IeqB_b);
			PutSOutFile (val.val_bool ? " TRUE" : " FALSE");
clean's avatar
clean committed
1065 1066
			break;
		case CharObj:
1067 1068
			put_instruction (IeqC_b);
			Put_SOutFile (val.val_char);
1069
			break;
clean's avatar
clean committed
1070
		case RealObj:
1071 1072
			put_instruction (IeqR_b);
			Put_SOutFile (val.val_real);
1073
			break;
clean's avatar
clean committed
1074 1075 1076 1077
		default:
			error_in_function ("EqBasic");
			return;
	}
1078
	put_arguments_n_b (offset);
clean's avatar
clean committed
1079 1080
}

1081 1082 1083 1084 1085
void GenNotB (void)
{
	put_instruction (InotB);
}

clean's avatar
clean committed
1086 1087 1088 1089 1090 1091
void PushBasicFromAOnB (ObjectKind kind,int offset)
{
	switch (kind){
		case IntObj:
		case ProcIdObj:
		case RedIdObj:
1092
			put_instructionb (pushI_a);
clean's avatar
clean committed
1093 1094
			break;
		case BoolObj:
1095
			put_instructionb (pushB_a);
clean's avatar
clean committed
1096 1097
			break;
		case CharObj:
1098
			put_instructionb (pushC_a);
clean's avatar
clean committed
1099 1100
			break;
		case RealObj:
1101
			put_instructionb (pushR_a);
clean's avatar
clean committed
1102 1103
			break;
		case FileObj:
1104
			put_instructionb (pushF_a);
clean's avatar
clean committed
1105 1106 1107 1108 1109
			break;
		default:
			error_in_function ("PushBasicFromAOnB");
			return;
	}
1110
	put_arguments_n_b (offset);
clean's avatar
clean committed
1111 1112 1113 1114
}

void GenPushD_a (int a_offset)
{
1115 1116
	put_instruction (IpushD_a);
	put_arguments_n_b (a_offset);
clean's avatar
clean committed
1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 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
}
	
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'.
*/

1189
static char BElems[] = BASIC_ELEMS_STRING;
clean's avatar
clean committed
1190 1191 1192 1193 1194

static void GenBStackElems (StateS state)
{
	if (IsSimpleState (state)){
		if (state.state_kind == OnB)
1195
			PutCOutFile (BElems [(int) state.state_object]);			
clean's avatar
clean committed
1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221
	} 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)
1222
			PutCOutFile (BElems [(int) state.state_object]);
clean's avatar
clean committed
1223
		else
1224
			PutCOutFile ('a');
clean's avatar
clean committed
1225 1226 1227 1228 1229 1230
	} else {
		int arity;
		States argstates;
		
		switch (state.state_type){
			case TupleState:
1231
				argstates = state.state_tuple_arguments;			
1232
				PutCOutFile ('(');
1233 1234 1235
				if (state.state_arity>0){
					GenABStackElems (argstates[0]);
					for (arity=1; arity < state.state_arity; arity++){
1236
						PutCOutFile (',');
1237 1238 1239
						GenABStackElems (argstates[arity]);
					}
				}
1240
				PutCOutFile (')');
clean's avatar
clean committed
1241 1242 1243
				break;
			case RecordState:
				argstates = state.state_record_arguments;
1244
				PutCOutFile ('(');
1245 1246
				for (arity=0; arity < state.state_arity; arity++)
					GenABStackElems (argstates[arity]);
1247
				PutCOutFile (')');
1248
				return;
clean's avatar
clean committed
1249
			case ArrayState:
1250
				PutCOutFile ('a');
clean's avatar
clean committed
1251 1252 1253 1254 1255 1256 1257 1258
				return;
			default:
				error_in_function ("GenABStackElems");
				return;
		}
	}
}

1259 1260 1261 1262
static void GenABStackElemsForRecordDesc (StateS state)
{
	if (IsSimpleState (state)){
		if (state.state_kind == OnB)
1263
			PutCOutFile (BElems [(int) state.state_object]);
1264
		else
1265
			PutCOutFile ('a');
1266 1267 1268 1269 1270 1271 1272
	} else {
		int arity;
		States argstates;
		
		switch (state.state_type){
			case TupleState:
				argstates = state.state_tuple_arguments;			
1273
				PutCOutFile ('(');
1274 1275