irgen.a68

COMMENT

  this does not (necessarily) build a IR tree, but translates a tree into a set of calls to
  an abstract IR-emission library

COMMENT

PR include "ast.a68" PR
PR include "util.a68" PR
PR include "transform.a68" PR

MODE LOCATION  = UNION(REGISTER,INDIRECT,LABEL,IMMEDIATE,FLAGS);
MODE TEMPORARY = UNION(REGISTER,INDIRECT);
MODE REGISTER  = INT;
MODE LABEL    = STRING;
MODE INDIRECT  = STRUCT(REGISTER base, INT offset);
MODE IMMEDIATE = STRUCT(INT val, BOOL dummy);
MODE FLAGS     = STRUCT(STRING cond, BOOL dummy);

PR include "ir_x86.a68" PR

COMMENT
    premature optimizations; the root of all evil

    return optimization 
	- use function result directly.  
	  this causes the checks using the 'conflict' function to become necessary;
	  right now this "optimization" causes incorrect behaviour
    flag optimization
	  a trick to save on a conditional jumps in if statements
    commute optimization
	  saves on a temporary if the lhs is not a register but the rhs is
    rewrite optimization
	  rewrites expressions to fit FCFS allocation better
COMMENT

BOOL return optimization = FALSE;
BOOL flag optimization = TRUE;
BOOL commute optimization = TRUE;
BOOL rewrite optimization = TRUE;

PROC transduce = (REF DECLS ast)VOID:
BEGIN
    []STRING commutative ops = ("+", "*", "==", "!=");
    PROC commutative = (STRING op)BOOL:
	op MEMBER commutative ops;

    PROC is register = (LOCATION loc)BOOL:
	(loc | (REGISTER x): TRUE | FALSE);

    PROC conflict = (LOCATION a,b)BOOL:
	(a|(REGISTER p): (b|(REGISTER q): p = q | FALSE) | FALSE);

    OP NOT = (FLAGS flag)FLAGS:
	IF (cond OF flag)[1] = "n" THEN FLAGS((cond OF flag)[2:], ~) ELSE FLAGS("n"+cond OF flag,~) FI;

    FLAGS unconditional = ("",~);

    emit begin;
    emit data segment;

    for each decl (ast, (REF DECL dcl)VOID:
	(dcl | (DECLSTM stm): emit global var (id OF stm) | SKIP)
    );

    emit code segment;

    for each decl (ast, (REF DECL dcl)VOID:
	(dcl | (DECLFUN fun): 
	    IF (name OF id OF (args OF fun)[0])[1] /= "_" THEN #for reification#
		emit prolog (name OF id OF (args OF fun)[0], UPB args OF fun, frame size OF fun);
		%body OF fun;
		emit epilog
	    FI | SKIP)
    );

    emit startup;

    for each decl (ast, (REF DECL dcl)VOID:
	(dcl | (DECLSTM stm): %ASSIGN(id OF stm, value OF stm)  | SKIP)
    );

    emit prepare call (0);
    emit call ("main", 0);

    emit end;

    COMMENT
	transduce boolean expressions; go to YES if true, NO otherwise;
	if 'assumed' is true, the labels 'yes' is assumed to immediately follow;
	otherwise 'no' is assumed to follow
    COMMENT
    PROC elaborate = (EXPR cond, BOOL assumed, LABEL yes, no)VOID:
    BEGIN 
	PROC default = VOID:
	    IF assumed THEN emit jump (no, NOT ?%cond) ELSE emit jump (yes, ?%cond) FI;

	CASE cond IN
	    (DYAD d):
		IF repr OF op OF d = "&&" THEN
		    LABEL tmp = obtain label;
		    elaborate (lhs OF d, TRUE, tmp, no);
		    emit label (tmp);
		    elaborate (rhs OF d, assumed, yes, no)
		ELIF repr OF op OF d = "||" THEN
		    LABEL tmp = obtain label;
		    elaborate (lhs OF d, FALSE, yes, tmp);
		    emit label (tmp);
		    elaborate (rhs OF d, assumed, yes, no)
		ELSE
		    default
		FI,
	    (MONAD m):
		IF repr OF op OF m = "!" THEN
		    elaborate (lhs OF m, NOT assumed, no, yes)
		ELSE
		    default
		FI
	OUT 
	    default
	ESAC 
    END;

    OP % = (STM stm)VOID:
    CASE stm IN
	(ASSIGN stm):
	    BEGIN
		LOCATION src = %value OF stm;
		LOCATION dst = %id OF stm;
		emit move (dst, src)
	    END,
	(DECLSTM stm):
	    %ASSIGN(id OF stm, value OF stm),
	(FUNCALL call):
	    discard (%call),
	(RETURN ret):
	    BEGIN
		(value OF ret | (EXPR expr):
		    IF LOCATION tmp = %expr; NOT conflict (denote fun result, tmp) THEN
			emit move (denote fun result, tmp) FI);
		emit epilog
	    END,
	(REF STMLIST list):
	    for each stm (list, (REF STM stm)VOID: %stm),
	(IFSTM if):
	    BEGIN
		LABEL kick start = obtain label;
		LABEL false = obtain label;
		elaborate (cond OF if, TRUE, kick start, false);
		emit label (kick start);
		%then OF if;
		IF else OF if ISNT NIL THEN 
		    LABEL skip = obtain label;
		    emit jump (skip, unconditional);
		    emit label (false);
		    %else OF if;
		    emit label (skip)
		ELSE
		    emit label (false)
		FI
	    END,
	(WHILESTM whl):
	    BEGIN
		LABEL kick start = obtain label;
		LABEL loop = obtain label;
		LABEL exit = obtain label;
		emit jump (kick start, unconditional);
		emit label (loop);
		%body OF whl;
		emit label (kick start);
		elaborate (cond OF whl, FALSE, loop, exit);
		emit label (exit)
	    END
    OUT fatal error ("WHUIhuihudf")
    ESAC;

    OP % = (LOCATION loc)REGISTER:
    CASE loc IN
	(REGISTER dir): dir
    OUT 
	REGISTER tmp = obtain temporary;
	emit move (tmp, loc);
	tmp
    ESAC;

    OP % = (EXPR expr)LOCATION:
    CASE (rewrite optimization| optimize expression(expr,LOC INT) |expr) IN 
	(SYMBOL sym):
	    IF sym = "[]" OR sym = "False" THEN denote int (0) 
	    ELIF sym = "True" THEN denote int (1) ELSE
		fatal error ("unhandled symbol!?"); ~
	    FI,
	(CONST k):
	    denote int (int OF k),
	(IDENT id):
	    CASE DECLINFO info = info OF id; decl OF info IN
	    (PARAM p): denote parameter (pos OF info),
	    (DECL d):  IF pos OF info /= 0 THEN 
			   denote local var (pos OF info) 
		       ELSE
			   denote global var (name OF id)
		       FI
	    ESAC,
	(TUPLE tup):
	    BEGIN
		LOCATION lhs = !%lhs OF tup;
		LOCATION rhs = !%rhs OF tup;
		make pair (lhs, rhs)
	    END,
	(FUNCALL fun):
	    IF name OF id OF fun = "isEmpty" THEN
		emit cmp("e", %(args OF fun)[1], denote int(0))
	    ELIF name OF id OF fun MEMBER []STRING("hd", "fst") THEN
		INDIRECT(%%(args OF fun)[1], 0)
	    ELIF name OF id OF fun MEMBER []STRING("tl", "snd") THEN
		INDIRECT(%%(args OF fun)[1], 1)
	    ELSE
		emit prepare call (UPB args OF fun);
		FOR i TO UPB args OF fun DO
		    LOCATION src = !%(args OF fun)[i];
		    emit push arg (src, i)
		OD;
		emit call (name OF id OF fun, UPB args OF fun);
		IF return optimization THEN
		    denote fun result
		ELSE
		    LOCATION result = obtain temporary;
		    emit move (result, denote fun result);
		    result
		FI
	    FI,
	(MONAD expr):
	    BEGIN
		STRING op = repr OF op OF expr;
		REGISTER lhs = %%lhs OF expr;
		IF op = "!"   THEN 
		    emit mon("not",)
		ELIF op = "-" THEN 
		    emit mon("neg",)
		ELSE fatal error ("babies on spikes?!"); ~ 
		FI (lhs)
	    END,
	(DYAD expr):
	    BEGIN
		STRING op = repr OF op OF expr;
		PROC (LOCATION,LOCATION)LOCATION emit dyop = 
		    IF   op = "*" THEN emit bin("mul",,)
		    ELIF op = "/" THEN emit bin("div",,)
		    ELIF op = "%" THEN emit bin("mod",,)
		    ELIF op = "+" THEN emit bin("add",,)
		    ELIF op = "-" THEN emit bin("sub",,)
		    ELIF op = ">" THEN emit cmp("gt",,)
		    ELIF op = "<" THEN emit cmp("lt",,)
		    ELIF op = ">=" THEN emit cmp("ge",,)
		    ELIF op = "<=" THEN emit cmp("le",,)
		    ELIF op = "==" THEN emit cmp("e",,)
		    ELIF op = "!=" THEN emit cmp("ne",,)
		    ELIF op = ":" THEN make pair
		    ELIF op = "&&" OR op = "||" THEN ~
		    ELSE fatal error ("arranging matchboxes?!"); ~
		    FI;

		# todo: simplify: replace this with a call to elaborate #
		IF op = "&&" OR op = "||" THEN
		    LABEL shortcut = obtain label;
		    FLAGS lflag = ?%lhs OF expr;
		    emit jump (shortcut, (op="&&"|NOT lflag|lflag));
		    FLAGS rflag = ?%rhs OF expr;
		    IF flag optimization AND cond OF lflag = cond OF rflag THEN
			emit label (shortcut);
			lflag
		    ELSE
			REGISTER result = obtain temporary;
			LABEL leave = obtain label;
			#emit move (result, rflag);
			emit jump (leave, unconditional);#
			emit move (result, (op="&&"|1|0));
			emit jump (leave, rflag);
			emit label (shortcut);
			emit move (result, (op="&&"|0|1));
			emit label (leave);
			result
		    FI
		ELIF 
		    LOCATION lhs = !%lhs OF expr;
		    LOCATION rhs = !%rhs OF expr;
		    commutative (op) AND NOT is register (lhs) AND is register (rhs) AND commute optimization THEN
		    emit dyop (%rhs, lhs)
		ELSE
		    IF NOT conflict (lhs, rhs) THEN
			emit dyop (%lhs, rhs)
		    ELSE
			LOCATION tmp = obtain temporary;
			emit move (tmp, rhs);
			emit dyop (%lhs, tmp)
		    FI
		FI
	    END
	OUT
	    fatal error ("monkeys from outer space!"); ~
    ESAC;

    # two operators for converting to/from flags #
    OP ? = (LOCATION loc)FLAGS:
    CASE loc IN
	(FLAGS f): f,
	(IMMEDIATE i): 
	    (emit cmp ("ne", %loc, IMMEDIATE(0,~)); FLAGS("ne", ~))
    OUT
	emit cmp ("ne", loc, IMMEDIATE(0,~)); 
	FLAGS("ne", ~)
    ESAC;

    OP ! = (LOCATION loc)LOCATION:
	(loc | (FLAGS f): %f | loc);

    PROC make pair = (LOCATION a, b)LOCATION:
    BEGIN
	REGISTER handle = obtain heap;
	emit move (INDIRECT(handle, 0), a);
	emit move (INDIRECT(handle, 1), b);
	handle
    END;
	
    SKIP
END;