Chris@82: (*
Chris@82:  * Copyright (c) 1997-1999 Massachusetts Institute of Technology
Chris@82:  * Copyright (c) 2003, 2007-14 Matteo Frigo
Chris@82:  * Copyright (c) 2003, 2007-14 Massachusetts Institute of Technology
Chris@82:  *
Chris@82:  * This program is free software; you can redistribute it and/or modify
Chris@82:  * it under the terms of the GNU General Public License as published by
Chris@82:  * the Free Software Foundation; either version 2 of the License, or
Chris@82:  * (at your option) any later version.
Chris@82:  *
Chris@82:  * This program is distributed in the hope that it will be useful,
Chris@82:  * but WITHOUT ANY WARRANTY; without even the implied warranty of
Chris@82:  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
Chris@82:  * GNU General Public License for more details.
Chris@82:  *
Chris@82:  * You should have received a copy of the GNU General Public License
Chris@82:  * along with this program; if not, write to the Free Software
Chris@82:  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
Chris@82:  *
Chris@82:  *)
Chris@82: 
Chris@82: (*************************************************************
Chris@82:  * Conversion of the dag to an assignment list
Chris@82:  *************************************************************)
Chris@82: (*
Chris@82:  * This function is messy.  The main problem is that we want to
Chris@82:  * inline dag nodes conditionally, depending on how many times they
Chris@82:  * are used.  The Right Thing to do would be to modify the
Chris@82:  * state monad to propagate some of the state backwards, so that
Chris@82:  * we know whether a given node will be used again in the future.
Chris@82:  * This modification is trivial in a lazy language, but it is
Chris@82:  * messy in a strict language like ML.  
Chris@82:  *
Chris@82:  * In this implementation, we just do the obvious thing, i.e., visit
Chris@82:  * the dag twice, the first to count the node usages, and the second to
Chris@82:  * produce the output.
Chris@82:  *)
Chris@82: 
Chris@82: open Monads.StateMonad
Chris@82: open Monads.MemoMonad
Chris@82: open Expr
Chris@82: 
Chris@82: let fresh = Variable.make_temporary
Chris@82: let node_insert x =  Assoctable.insert Expr.hash x
Chris@82: let node_lookup x =  Assoctable.lookup Expr.hash (==) x
Chris@82: let empty = Assoctable.empty
Chris@82: 
Chris@82: let fetchAl = 
Chris@82:   fetchState >>= (fun (al, _, _) -> returnM al)
Chris@82: 
Chris@82: let storeAl al =
Chris@82:   fetchState >>= (fun (_, visited, visited') ->
Chris@82:     storeState (al, visited, visited'))
Chris@82: 
Chris@82: let fetchVisited = fetchState >>= (fun (_, v, _) -> returnM v)
Chris@82: 
Chris@82: let storeVisited visited =
Chris@82:   fetchState >>= (fun (al, _, visited') ->
Chris@82:     storeState (al, visited, visited'))
Chris@82: 
Chris@82: let fetchVisited' = fetchState >>= (fun (_, _, v') -> returnM v')
Chris@82: let storeVisited' visited' =
Chris@82:   fetchState >>= (fun (al, visited, _) ->
Chris@82:     storeState (al, visited, visited'))
Chris@82: let lookupVisitedM' key =
Chris@82:   fetchVisited' >>= fun table ->
Chris@82:     returnM (node_lookup key table)
Chris@82: let insertVisitedM' key value =
Chris@82:   fetchVisited' >>= fun table ->
Chris@82:     storeVisited' (node_insert key value table)
Chris@82: 
Chris@82: let counting f x =
Chris@82:   fetchVisited >>= (fun v ->
Chris@82:     match node_lookup x v with
Chris@82:       Some count -> 
Chris@82: 	let incr_cnt = 
Chris@82: 	  fetchVisited >>= (fun v' ->
Chris@82: 	    storeVisited (node_insert x (count + 1) v'))
Chris@82: 	in
Chris@82: 	begin
Chris@82: 	  match x with
Chris@82: 	    (* Uminus is always inlined.  Visit child *)
Chris@82: 	    Uminus y -> f y >> incr_cnt
Chris@82: 	  | _ -> incr_cnt
Chris@82: 	end
Chris@82:     | None ->
Chris@82:         f x >> fetchVisited >>= (fun v' ->
Chris@82:             storeVisited (node_insert x 1 v')))
Chris@82: 
Chris@82: let with_varM v x = 
Chris@82:   fetchAl >>= (fun al -> storeAl ((v, x) :: al)) >> returnM (Load v)
Chris@82: 
Chris@82: let inlineM = returnM
Chris@82: 
Chris@82: let with_tempM x = match x with
Chris@82: | Load v when Variable.is_temporary v -> inlineM x (* avoid trivial moves *)
Chris@82: |  _ -> with_varM (fresh ()) x
Chris@82: 
Chris@82: (* declare a temporary only if node is used more than once *)
Chris@82: let with_temp_maybeM node x =
Chris@82:   fetchVisited >>= (fun v ->
Chris@82:     match node_lookup node v with
Chris@82:       Some count -> 
Chris@82:         if (count = 1 && !Magic.inline_single) then
Chris@82:           inlineM x
Chris@82:         else
Chris@82:           with_tempM x
Chris@82:     | None ->
Chris@82:         failwith "with_temp_maybeM")
Chris@82: type fma = 
Chris@82:     NO_FMA
Chris@82:   | FMA of expr * expr * expr   (* FMA (a, b, c) => a + b * c *)
Chris@82:   | FMS of expr * expr * expr   (* FMS (a, b, c) => -a + b * c *)
Chris@82:   | FNMS of expr * expr * expr  (* FNMS (a, b, c) => a - b * c *)
Chris@82: 
Chris@82: let good_for_fma (a, b) = 
Chris@82:   let good = function
Chris@82:     | NaN I -> true
Chris@82:     | NaN CONJ -> true
Chris@82:     | NaN _ -> false
Chris@82:     | Times(NaN _, _) -> false
Chris@82:     | Times(_, NaN _) -> false
Chris@82:     | _ -> true
Chris@82:   in good a && good b
Chris@82: 
Chris@82: let build_fma l = 
Chris@82:   if (not !Magic.enable_fma) then NO_FMA
Chris@82:   else match l with
Chris@82:   | [a; Uminus (Times (b, c))] when good_for_fma (b, c) -> FNMS (a, b, c)
Chris@82:   | [Uminus (Times (b, c)); a] when good_for_fma (b, c) -> FNMS (a, b, c)
Chris@82:   | [Uminus a; Times (b, c)] when good_for_fma (b, c) -> FMS (a, b, c)
Chris@82:   | [Times (b, c); Uminus a] when good_for_fma (b, c) -> FMS (a, b, c)
Chris@82:   | [a; Times (b, c)] when good_for_fma (b, c) -> FMA (a, b, c)
Chris@82:   | [Times (b, c); a] when good_for_fma (b, c) -> FMA (a, b, c)
Chris@82:   | _ -> NO_FMA
Chris@82: 
Chris@82: let children_fma l = match build_fma l with
Chris@82: | FMA (a, b, c) -> Some (a, b, c)
Chris@82: | FMS (a, b, c) -> Some (a, b, c)
Chris@82: | FNMS (a, b, c) -> Some (a, b, c)
Chris@82: | NO_FMA -> None
Chris@82: 
Chris@82: 
Chris@82: let rec visitM x =
Chris@82:   counting (function
Chris@82:     | Load v -> returnM ()
Chris@82:     | Num a -> returnM ()
Chris@82:     | NaN a -> returnM ()
Chris@82:     | Store (v, x) -> visitM x
Chris@82:     | Plus a -> (match children_fma a with
Chris@82: 	None -> mapM visitM a >> returnM ()
Chris@82:       | Some (a, b, c) -> 
Chris@82:           (* visit fma's arguments twice to make sure they are not inlined *)
Chris@82: 	  visitM a >> visitM a >>
Chris@82: 	  visitM b >> visitM b >>
Chris@82: 	  visitM c >> visitM c)
Chris@82:     | Times (a, b) -> visitM a >> visitM b
Chris@82:     | CTimes (a, b) -> visitM a >> visitM b
Chris@82:     | CTimesJ (a, b) -> visitM a >> visitM b
Chris@82:     | Uminus a -> visitM a)
Chris@82:     x
Chris@82: 
Chris@82: let visit_rootsM = mapM visitM
Chris@82: 
Chris@82: 
Chris@82: let rec expr_of_nodeM x =
Chris@82:   memoizing lookupVisitedM' insertVisitedM'
Chris@82:     (function x -> match x with
Chris@82:     | Load v -> 
Chris@82: 	if (Variable.is_temporary v) then
Chris@82: 	  inlineM (Load v)
Chris@82: 	else if (Variable.is_locative v && !Magic.inline_loads) then
Chris@82:           inlineM (Load v)
Chris@82:         else if (Variable.is_constant v && !Magic.inline_loads_constants) then
Chris@82:           inlineM (Load v)
Chris@82: 	else
Chris@82:           with_tempM (Load v)
Chris@82:     | Num a ->
Chris@82:         if !Magic.inline_constants then
Chris@82:           inlineM (Num a)
Chris@82: 	else
Chris@82:           with_temp_maybeM x (Num a)
Chris@82:     | NaN a -> inlineM (NaN a)
Chris@82:     | Store (v, x) -> 
Chris@82:         expr_of_nodeM x >>= 
Chris@82: 	(if !Magic.trivial_stores then with_tempM else inlineM) >>=
Chris@82:         with_varM v 
Chris@82: 
Chris@82:     | Plus a -> 
Chris@82: 	begin
Chris@82: 	  match build_fma a with
Chris@82: 	    FMA (a, b, c) ->	  
Chris@82: 	      expr_of_nodeM a >>= fun a' ->
Chris@82: 		expr_of_nodeM b >>= fun b' ->
Chris@82: 		  expr_of_nodeM c >>= fun c' ->
Chris@82: 		    with_temp_maybeM x (Plus [a'; Times (b', c')])
Chris@82: 	  | FMS (a, b, c) ->	  
Chris@82: 	      expr_of_nodeM a >>= fun a' ->
Chris@82: 		expr_of_nodeM b >>= fun b' ->
Chris@82: 		  expr_of_nodeM c >>= fun c' ->
Chris@82: 		    with_temp_maybeM x 
Chris@82: 		      (Plus [Times (b', c'); Uminus a'])
Chris@82: 	  | FNMS (a, b, c) ->	  
Chris@82: 	      expr_of_nodeM a >>= fun a' ->
Chris@82: 		expr_of_nodeM b >>= fun b' ->
Chris@82: 		  expr_of_nodeM c >>= fun c' ->
Chris@82: 		    with_temp_maybeM x 
Chris@82: 		      (Plus [a'; Uminus (Times (b', c'))])
Chris@82: 	  | NO_FMA ->
Chris@82:               mapM expr_of_nodeM a >>= fun a' ->
Chris@82: 		with_temp_maybeM x (Plus a')
Chris@82: 	end
Chris@82:     | CTimes (Load _ as a, b) when !Magic.generate_bytw ->
Chris@82:         expr_of_nodeM b >>= fun b' ->
Chris@82:           with_tempM (CTimes (a, b'))
Chris@82:     | CTimes (a, b) ->
Chris@82:         expr_of_nodeM a >>= fun a' ->
Chris@82:           expr_of_nodeM b >>= fun b' ->
Chris@82:             with_tempM (CTimes (a', b'))
Chris@82:     | CTimesJ (Load _ as a, b) when !Magic.generate_bytw ->
Chris@82:         expr_of_nodeM b >>= fun b' ->
Chris@82:           with_tempM (CTimesJ (a, b'))
Chris@82:     | CTimesJ (a, b) ->
Chris@82:         expr_of_nodeM a >>= fun a' ->
Chris@82:           expr_of_nodeM b >>= fun b' ->
Chris@82:             with_tempM (CTimesJ (a', b'))
Chris@82:     | Times (a, b) ->
Chris@82:         expr_of_nodeM a >>= fun a' ->
Chris@82:           expr_of_nodeM b >>= fun b' ->
Chris@82: 	    begin
Chris@82: 	      match a' with
Chris@82: 		Num a'' when !Magic.strength_reduce_mul && Number.is_two a'' ->
Chris@82: 		  (inlineM b' >>= fun b'' ->
Chris@82: 		    with_temp_maybeM x (Plus [b''; b'']))
Chris@82: 	      | _ -> with_temp_maybeM x (Times (a', b'))
Chris@82: 	    end
Chris@82:     | Uminus a ->
Chris@82:         expr_of_nodeM a >>= fun a' ->
Chris@82:           inlineM (Uminus a'))
Chris@82:     x
Chris@82: 
Chris@82: let expr_of_rootsM = mapM expr_of_nodeM
Chris@82: 
Chris@82: let peek_alistM roots =
Chris@82:   visit_rootsM roots >> expr_of_rootsM roots >> fetchAl
Chris@82: 
Chris@82: let wrap_assign (a, b) = Expr.Assign (a, b)
Chris@82: 
Chris@82: let to_assignments dag =
Chris@82:   let () = Util.info "begin to_alist" in
Chris@82:   let al = List.rev (runM ([], empty, empty) peek_alistM dag) in
Chris@82:   let res = List.map wrap_assign al in
Chris@82:   let () = Util.info "end to_alist" in
Chris@82:   res
Chris@82: 
Chris@82: 
Chris@82: (* dump alist in `dot' format *)
Chris@82: let dump print alist =
Chris@82:   let vs v = "\"" ^ (Variable.unparse v) ^ "\"" in
Chris@82:   begin
Chris@82:     print "digraph G {\n";
Chris@82:     print "\tsize=\"6,6\";\n";
Chris@82: 
Chris@82:     (* all input nodes have the same rank *)
Chris@82:     print "{ rank = same;\n";
Chris@82:     List.iter (fun (Expr.Assign (v, x)) ->
Chris@82:       List.iter (fun y -> 
Chris@82: 	if (Variable.is_locative y) then print("\t" ^ (vs y) ^ ";\n"))
Chris@82: 	(Expr.find_vars x))
Chris@82:       alist;
Chris@82:     print "}\n";
Chris@82: 
Chris@82:     (* all output nodes have the same rank *)
Chris@82:     print "{ rank = same;\n";
Chris@82:     List.iter (fun (Expr.Assign (v, x)) ->
Chris@82:       if (Variable.is_locative v) then print("\t" ^ (vs v) ^ ";\n"))
Chris@82:       alist;
Chris@82:     print "}\n";
Chris@82:     
Chris@82:     (* edges *)
Chris@82:     List.iter (fun (Expr.Assign (v, x)) ->
Chris@82:       List.iter (fun y -> print("\t" ^ (vs y) ^ " -> " ^ (vs v) ^ ";\n"))
Chris@82: 	(Expr.find_vars x))
Chris@82:       alist;
Chris@82: 
Chris@82:     print "}\n";
Chris@82:   end
Chris@82: