(* expr-fn.sml
 *
 * This code is part of the Diderot Project (http://diderot-language.cs.uchicago.edu)
 *
 * COPYRIGHT (c) 2015 The University of Chicago
 * All rights reserved.
 *
 * This functor implements hash-consing for IL expressions.  It can be used to implement
 * optimizations such as CSE and PRE.
 *)

signature EXPR =
  sig

    structure IL : SSA
    structure Op : OPERATORS where type rator = IL.Op.rator

    datatype expr_nd
      = STATE of IL.state_var
      | VAR of IL.var
      | LIT of Literal.literal
      | OP of Op.rator * expr list
      | MULTIOP of int * Op.rator * expr list     (* n'th result of operator in multi-assignment *)
      | APPLY of MathFuns.name * expr list
      | CONS of IL.Ty.ty * expr list
      | PHI of expr list

    withtype expr = expr_nd HashCons.obj

    val same : expr * expr -> bool
    val toString : expr -> string

  (* hash-cons construction of expressions *)
    type tbl

    val new : unit -> tbl

    val mkSTATE : tbl -> IL.state_var -> expr
    val mkVAR   : tbl -> IL.var -> expr
    val mkLIT   : tbl -> Literal.literal -> expr
    val mkOP    : tbl -> Op.rator * expr list -> expr
    val mkMULTIOP : tbl -> int * Op.rator * expr list -> expr
    val mkAPPLY : tbl -> MathFuns.name * expr list -> expr
    val mkCONS  : tbl -> IL.Ty.ty * expr list -> expr
    val mkPHI   : tbl -> expr list -> expr

  (* tables, sets, and maps *)
    structure Tbl : MONO_HASH_TABLE where type Key.hash_key = expr
    structure Set : ORD_SET where type Key.ord_key = expr
    structure Map : ORD_MAP where type Key.ord_key = expr

  end

functor ExprFn (IL : SSA) : EXPR =
  struct

    structure IL = IL
    structure Op = IL.Op
    structure HC = HashCons

    datatype expr_nd
      = STATE of IL.state_var
      | VAR of IL.var
      | LIT of Literal.literal
      | OP of Op.rator * expr list
      | MULTIOP of int * Op.rator * expr list     (* n'th result of operator *)
      | APPLY of MathFuns.name * expr list
      | CONS of IL.Ty.ty * expr list
      | PHI of expr list

    withtype expr = expr_nd HashCons.obj

    val same : expr * expr -> bool = HC.same
    val same' = ListPair.allEq same

    fun sameNd (STATE x, STATE y) = IL.StateVar.same(x, y)
      | sameNd (VAR x, VAR y) = IL.Var.same(x, y)
      | sameNd (LIT a, LIT b) = Literal.same(a, b)
      | sameNd (OP(op1, args1), OP(op2, args2)) =
	  Op.same(op1, op2) andalso Op.isPure op1 andalso same'(args1, args2)
      | sameNd (MULTIOP(i1, op1, args1), MULTIOP(i2, op2, args2)) =
	  (i1 = i2) andalso Op.same(op1, op2) andalso same'(args1, args2)
      | sameNd (APPLY(f1, args1), APPLY(f2, args2)) =
	  MathFuns.same(f1, f2) andalso same'(args1, args2)
      | sameNd (CONS(_, args1), CONS(_, args2)) = same'(args1, args2)
      | sameNd (PHI args1, PHI args2) = same'(args1, args2)
      | sameNd _ = false

    fun toString exp = let
          fun toS (e : expr, l) = (case #nd e
                 of STATE x => IL.StateVar.toString x :: l
                  | VAR x => IL.Var.toString x :: l
                  | LIT lit => Literal.toString lit :: l
                  | OP(rator, args) => Op.toString rator :: "(" :: argsToS (args, ")" :: l)
                  | MULTIOP(i, rator, args) =>
                      "#" :: Int.toString i :: "(" :: Op.toString rator :: "("
                        :: argsToS (args, "))" :: l)
                  | APPLY(f, args) => MathFuns.toString f :: "(" :: argsToS (args, ")" :: l)
                  | CONS(ty, args) => "<" :: IL.Ty.toString ty :: ">[" :: argsToS (args, "]" :: l)
                  | PHI args => "PHI(" :: argsToS (args, ")" :: l)
                (* end case *))
          and argsToS ([], l) = l
            | argsToS ([e], l) = toS(e, l)
            | argsToS (e::es, l) = toS(e, ","::argsToS(es, l))
          in
            String.concat (toS (exp, []))
          end

  (* hash-cons construction of expressions *)
    datatype tbl = Tbl of expr_nd HC.tbl

    fun new () = Tbl(HC.new{eq = sameNd})

    fun mkSTATE (Tbl tbl) x = HC.cons0 tbl (0w7477 + IL.StateVar.hash x, STATE x)
    fun mkVAR (Tbl tbl) x = HC.cons0 tbl (0w7919 + IL.Var.hash x, VAR x)
    fun mkLIT (Tbl tbl) a = HC.cons0 tbl (0w6997 + Literal.hash a, LIT a)
    fun mkOP (Tbl tbl) (rator, args) =
	  HC.consList tbl (Op.hash rator, fn args => OP(rator, args)) args
    fun mkMULTIOP (Tbl tbl) (i, rator, args) =
	  HC.consList tbl (Op.hash rator + Word.fromInt i, fn args => OP(rator, args)) args
    fun mkAPPLY (Tbl tbl) (f, args) =
	  HC.consList tbl (MathFuns.hash f, fn args => APPLY(f, args)) args
    fun mkCONS (Tbl tbl) (ty, args) =
	  HC.consList tbl (0w5987, fn args => CONS(ty, args)) args
    fun mkPHI (Tbl tbl) args = HC.consList tbl (0w6079, PHI) args

  (* hash tables *)
    structure Tbl = HashTableFn (
      struct
	type hash_key = expr
	fun hashVal (e : expr) = #tag e
	val sameKey = same
      end)

  (* sets and maps *)
    structure Ord =
      struct
	type ord_key = expr
	fun compare (e1 : expr, e2 : expr) = Word.compare(#tag e1, #tag e2)
      end
    structure Set = RedBlackSetFn (Ord)
    structure Map = RedBlackMapFn (Ord)

  end

<script type="text/javascript">//<![CDATA[
		function toggle_ffErrors() {
			var errorsblock = document.getElementById("ffErrorsBlock");
			var errorsgroup = document.getElementById("ffErrors");
			if (errorsblock.style.display == "none") {
				errorsblock.style.display = "block";
				errorsgroup.style.right = "10px";
			} else {
				errorsblock.style.display = "none";
				errorsgroup.style.right = "300px";
			}
		}
//]]></script>
<div id="ffErrors">
<a href="javascript:toggle_ffErrors();">Click to toggle</a>
<div id="ffErrorsBlock">
	<div class="error">does not end with &lt;/html&gt; tag</div>
	<div class="error">does not end with &lt;/body&gt; tag</div>
	<div class="info">The output has ended thus: e2)
      end
    structure Set = RedBlackSetFn (Ord)
    structure Map = RedBlackMapFn (Ord)

  end</div>
</div></div>
</body></html>