(*
 * Copyright (c) 2001-2002 Stefan Kral
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *
 *)

(* This module contains code for the 2-way SIMD vectorization. *)


open Id
open List 
open Util
open Expr
open Variable
open Number
open VFpBasics
open VFpUnparsing
open BalanceVfpinstrs
open VSimdBasics
open VSimdUnparsing

exception OutOfTime

type fpfuse =
  | ReImSimd of vfpreg * vfpreg * vsimdreg
  | ImReSimd of vfpreg * vfpreg * vsimdreg

type vect_instr_tupel =
  | SingleVect of (Id.t * vfpinstr)
  | DualVect of vsimdreg * (Id.t * vfpinstr) * (Id.t * vfpinstr)

type fusemode = 
  | FuseModeSrc
  | FuseModeDst

type vectorization_grade =
  | VECTGRADE_FULL

let vectorizationgradeToString = function
  | VECTGRADE_FULL -> "VECTGRADE_FULL"

let vectorization_grades = [VECTGRADE_FULL]

let transformlength = ref 0
let current_vectorization_grade = ref VECTGRADE_FULL
let vect_steps = ref 0

let incr_vect_steps () = 
  incr vect_steps; 
  if !vect_steps > !Magic.vectsteps_limit then 
    raise OutOfTime 
  else if !vect_steps mod 20000 = 0 then 
    info (Printf.sprintf "vectsteps = %d" !vect_steps) 
  else
    ()

(*****************************************************************************)

open NonDetMonad
open NonDetUtils

(* functions for accessing the monadic state *)
let fetchVarInfoM	 = fetchStateM >>= fun s -> unitM (get1of6 s) 
let fetchVisitedM	 = fetchStateM >>= fun s -> unitM (get2of6 s)
let fetchFpFusesM	 = fetchStateM >>= fun s -> unitM (get3of6 s)
let fetchSimdInstrsM	 = fetchStateM >>= fun s -> unitM (get4of6 s)
let fetchIdxInfoM	 = fetchStateM >>= fun s -> unitM (get5of6 s)
let fetchDepthsM	 = fetchStateM >>= fun s -> unitM (get6of6 s)
 
let storeVisitedM x	 = fetchStateM >>= fun s -> storeStateM (repl2of6 x s)
let storeFpFusesM x	 = fetchStateM >>= fun s -> storeStateM (repl3of6 x s)
let storeSimdInstrsM x   = fetchStateM >>= fun s -> storeStateM (repl4of6 x s)

let addToVisitedM id = 
  fetchVisitedM >>= fun ids ->
    negAssertM (IdSet.mem id ids) >>= fun _ ->
      storeVisitedM (IdSet.add id ids)

let addSimdInstrM i = fetchSimdInstrsM >>= consM i >>= storeSimdInstrsM 

let addSimdBinOpM op d (s1,s2) = addSimdInstrM (V_SimdBinaryOp(op,s1,s2,d))

let addSimdChsLoSubM d (s,t) =			   (* used with add/sub *)
  let t' = makeNewVsimdreg () in
    addSimdInstrM (V_SimdUnaryOp(V_Chs V_ChsLo,t,t')) >>= fun _ ->
    addSimdInstrM (V_SimdBinaryOp(V_Sub2,s,t',d))

let addSimdChsHiAddM d (s,t) =			 (* used with x add/sub *)
  let s' = makeNewVsimdreg () in
    addSimdInstrM (V_SimdUnaryOp(V_Chs V_ChsHi,s,s')) >>= fun _ ->
    addSimdInstrM (V_SimdBinaryOp(V_Add2,s',t,d))

let addSimdChsLoAddM d (s,t) =		(* used with sub/add, x sub/add *)
  let t' = makeNewVsimdreg () in
    addSimdInstrM (V_SimdUnaryOp(V_Chs V_ChsLo,t,t')) >>= fun _ ->
    addSimdInstrM (V_SimdBinaryOp(V_Add2,s,t',d))

let addSimdSubChsHiM d (s,t) =			 (* used with x sub/sub *)
  let d' = makeNewVsimdreg () in
    addSimdInstrM (V_SimdBinaryOp(V_Sub2,s,t,d')) >>= fun _ ->
    addSimdInstrM (V_SimdUnaryOp(V_Chs V_ChsHi,d',d))

(*****************************************************************************)

let fullvectgradeAllows = function
  | V_FPStore _, V_FPStore _ -> true
  | V_FPLoad _, V_FPLoad _ -> true
  | V_FPUnaryOp(op1,s1,_), V_FPUnaryOp(op2,s2,_) -> s1<>s2
  | V_FPBinaryOp(V_FPMul,_,_,_), V_FPBinaryOp(V_FPMul,_,_,_) -> true
  | V_FPBinaryOp(op1,_,_,_), V_FPBinaryOp(op2,_,_,_) ->
      vfpbinaryopIsAddorsub op1 && vfpbinaryopIsAddorsub op2
  | V_FPAddL(xs,_), V_FPAddL(zs,_) -> same_length xs zs && length xs > 2
  | _ -> false

(****************************************************************************)

let currentvectgradeAllowsPairing pair = 
  match !current_vectorization_grade with
    | VECTGRADE_FULL -> fullvectgradeAllows pair
  
let currentvectgradeAllowsIds instr_depths (id_a,id_b) =
  match !current_vectorization_grade with
    | VECTGRADE_FULL -> 
	IdMap.find id_a instr_depths = IdMap.find id_b instr_depths

let basicallyCompatibleM ((id_a,a),(id_b,b)) = 
  posAssertM (currentvectgradeAllowsPairing (a,b)) >>= fun _ ->
    fetchDepthsM >>= fun depths ->
      posAssertM (currentvectgradeAllowsIds depths (id_a,id_b))

(****************************************************************************)

let compatibleFusesM mode = function
  | ReImSimd(x,y,z), ImReSimd(y',x',z') when x=x' && y=y' && z=z' ->
      unitM z
  | ImReSimd(y,x,z), ReImSimd(x',y',z') when x=x' && y=y' && z=z' ->
      let z' = makeNewVsimdreg () in
        (match mode with
	   | FuseModeSrc -> addSimdInstrM (V_SimdUnaryOp(V_Swap,z,z'))
	   | FuseModeDst -> addSimdInstrM (V_SimdUnaryOp(V_Swap,z',z))) 
  	>>= fun _ ->
	  unitM z'
  | _ ->
      failM

let compatibleVisitedForDualVectM s1_id s2_id = 
  if s1_id=s2_id then
    failM 
  else
    fetchVisitedM >>= fun visited ->
      posAssertM (IdSet.mem s1_id visited = IdSet.mem s2_id visited)

(****************************************************************************)

let getUnvisitedLoadM () = 
  fetchIdxInfoM >>= fun (loads,_,_) -> 
    memberM loads >>= fun ((id,_) as pair) -> 
      addToVisitedM id >>= fun _ -> 
	unitM pair

let getUnvisitedStoreM () = 
  fetchIdxInfoM >>= fun (_,stores,_) ->
    memberM stores >>= fun ((id,_) as pair) -> 
      addToVisitedM id >>= fun _ ->
	unitM pair

(****************************************************************************)

let scalarvfpunaryopToVsimdunaryop op pos = match (pos,op) with
  | (_, V_FPId)	   	        -> V_Id
  | (p, V_FPNegate)             -> V_Chs p
  | (V_ChsLo, V_FPMulConst n)   -> V_MulConst(n, Number.one)
  | (V_ChsHi, V_FPMulConst n)   -> V_MulConst(Number.one, n)
  | (V_ChsLoHi, V_FPMulConst n) -> V_MulConst(n, n)

let unaryoppairToSimdunaryopM = function 
  | (V_FPId, op_h) -> unitM (scalarvfpunaryopToVsimdunaryop op_h V_ChsHi)
  | (op_l, V_FPId) -> unitM (scalarvfpunaryopToVsimdunaryop op_l V_ChsLo)
  | (V_FPNegate, V_FPNegate) -> unitM (V_Chs(V_ChsLoHi))
  | (V_FPNegate, V_FPMulConst h) -> unitM (V_MulConst(Number.mone,h))
  | (V_FPMulConst l, V_FPNegate) -> unitM (V_MulConst(l,Number.mone))
  | (V_FPMulConst l, V_FPMulConst h) -> unitM (V_MulConst(l,h))

(****************************************************************************)

let srcsToParpair (s1,t1,s2,t2) = ((s1,s2), (t1,t2))
let srcsToChipair (s1,t1,s2,t2) = ((s1,t2), (t1,s2))
let srcsToAccpair (s1,t1,s2,t2) = ((s1,t1), (s2,t2))

let addNewFpFuseM re im simd =
  fetchFpFusesM >>= fun fp_fuses' ->
    let fp_fuses'' = vfpregmap_addE re (ReImSimd(re,im,simd)) fp_fuses' in
      storeFpFusesM (vfpregmap_addE im (ImReSimd(im,re,simd)) fp_fuses'')

let addFpFuseM s1 s2 =
  posAssertM (s1<>s2) >>= fun _ ->
    fetchIdxInfoM >>= fun (_,_,writers) ->
      let ((s1_id,_) as s1_writer) = VFPRegMap.find s1 writers 
      and ((s2_id,_) as s2_writer) = VFPRegMap.find s2 writers in
	compatibleVisitedForDualVectM s1_id s2_id >>= fun _ ->
	  basicallyCompatibleM (s1_writer,s2_writer) >>= fun _ ->
	    let simd = makeNewVsimdreg () in
	      addNewFpFuseM s1 s2 simd >>= fun _ ->
	        unitM (simd,[DualVect(simd,s1_writer,s2_writer)])

let fuseNewM () = 
  let (t_re,t_im) = (makeNewVfpreg (), makeNewVfpreg ())
  and t_simd = makeNewVsimdreg () in
    addNewFpFuseM t_re t_im t_simd >>= fun _ ->
      unitM (t_simd,t_re,t_im)

let fuseM mode = function
  | (re,im) when re=im -> failM
  | (re,im) ->
      fetchFpFusesM >>= fun map ->
	match (vfpregmap_findE re map, vfpregmap_findE im map) with
	    | [],[] -> addFpFuseM re im
	    | (_::_ as xs), (_::_ as zs) ->
		 memberM xs >>= fun x ->
		   memberM zs >>= fun z ->
		     compatibleFusesM mode (x,z) >>= fun simd ->
			unitM (simd,[])
	    | _ -> failM

let fuseSrcM p = fuseM FuseModeSrc p
let fuseDstM p = fuseM FuseModeDst p >>= fun (d_simd,_) -> unitM d_simd

(*****************************************************************************)

let fuseSrcPair_ParM srcs = mapPairM fuseSrcM (srcsToParpair srcs)
let fuseSrcPair_ChiM srcs = mapPairM fuseSrcM (srcsToChipair srcs)
let fuseSrcPair_AccM srcs = mapPairM fuseSrcM (srcsToAccpair srcs)

(*****************************************************************************)

(* add/add *)
let parAddAdd = (fuseSrcPair_ParM, addSimdBinOpM V_Add2)
and chiAddAdd = (fuseSrcPair_ChiM, addSimdBinOpM V_Add2)
and posposAcc = (fuseSrcPair_AccM, addSimdBinOpM (V_Acc2 (V_Pos,V_Pos)))

let addAdd_Set1 = [ parAddAdd; chiAddAdd ]
and addAdd_Set2 = [ parAddAdd; chiAddAdd; posposAcc ]
and addAdd_Set3 = [ posposAcc; parAddAdd; chiAddAdd ]


(* add/sub *)
let parAddSub = (fuseSrcPair_ParM, addSimdChsLoSubM)
and chiAddSub = (fuseSrcPair_ChiM, addSimdChsHiAddM)
and posnegAcc = (fuseSrcPair_AccM, addSimdBinOpM (V_Acc2 (V_Pos,V_Neg)))

let addSub_Set1 = [ parAddSub; chiAddSub ]
and addSub_Set2 = [ parAddSub; chiAddSub; posnegAcc ]
and addSub_Set3 = [ posnegAcc; parAddSub; chiAddSub ]


(* sub/add *)
let parSubAdd = (fuseSrcPair_ParM, addSimdChsLoAddM)
and chiSubAdd = (fuseSrcPair_ChiM, addSimdChsLoAddM)
and negposAcc = (fuseSrcPair_AccM, addSimdBinOpM (V_Acc2 (V_Neg,V_Pos)))

let subAdd_Set1 = [ parSubAdd; chiSubAdd ]
and subAdd_Set2 = [ parSubAdd; chiSubAdd; negposAcc ]
and subAdd_Set3 = [ negposAcc; parSubAdd; chiSubAdd ]


(* sub/sub *)
let parSubSub = (fuseSrcPair_ParM, addSimdBinOpM V_Sub2)
and chiSubSub = (fuseSrcPair_ChiM, addSimdSubChsHiM)
and negnegAcc = (fuseSrcPair_AccM, addSimdBinOpM (V_Acc2 (V_Neg,V_Neg)))

let subSub_Set1 = [ parSubSub; chiSubSub ]
and subSub_Set2 = [ parSubSub; chiSubSub; negnegAcc ]
and subSub_Set3 = [ negnegAcc; parSubSub; chiSubSub ]


(* mul/mul *)
let parMulMul = (fuseSrcPair_ParM, addSimdBinOpM V_Mul2)
and chiMulMul = (fuseSrcPair_ChiM, addSimdBinOpM V_Mul2)

let mulMul_Set1 = [ parMulMul; chiMulMul ]

(****************************************************************************)

let vectFp_AddAdd_Fns = ref []
let vectFp_AddSub_Fns = ref []
let vectFp_SubAdd_Fns = ref []
let vectFp_SubSub_Fns = ref []

let binoppairToVectfnM = function
  | (V_FPMul, V_FPMul) -> memberM mulMul_Set1
  | (V_FPAdd, V_FPAdd) -> memberM !vectFp_AddAdd_Fns
  | (V_FPAdd, V_FPSub) -> memberM !vectFp_AddSub_Fns
  | (V_FPSub, V_FPAdd) -> memberM !vectFp_SubAdd_Fns
  | (V_FPSub, V_FPSub) -> memberM !vectFp_SubSub_Fns
  | _ -> failM

(****************************************************************************)

let vectorizeLoadM (s1_access,s1_arr,s1_idx,d1) (s2_access,s2_arr,s2_idx,d2) = 
  fetchVarInfoM >>= fun varinfo ->
    match (assoc s1_arr varinfo, assoc s2_arr varinfo) with
      | (ComplexArray(InterleavedFormat), ComplexArray(InterleavedFormat)) ->
	  posAssertM (s1_arr=s2_arr && s1_idx=s2_idx) >>= fun _ ->
	    (match (s1_access,s2_access) with
	       | (V_FPRealOfComplex,V_FPImagOfComplex) -> unitM (d1,d2)
	       | (V_FPImagOfComplex,V_FPRealOfComplex) -> unitM (d2,d1)
	       | _ -> failM) 
	    >>= fun fuse_pair ->
	      fuseDstM fuse_pair >>= fun d_simd ->
	        addSimdInstrM (V_SimdLoad2(s1_arr,s1_idx,d_simd)) >>= fun _ ->
	          unitM []
      | _ -> failM

(****************************************************************************)

let vectorizeStoreM (s1,d1_access,d1_arr,d1_idx) (s2,d2_access,d2_arr,d2_idx) =
  fetchVarInfoM >>= fun varinfo ->
    match (assoc d1_arr varinfo, assoc d2_arr varinfo) with
      | (ComplexArray(InterleavedFormat), ComplexArray(InterleavedFormat)) ->
  	  posAssertM (d1_arr=d2_arr && d1_idx=d2_idx) >>= fun _ ->
	    (match (d1_access,d2_access) with
	       | (V_FPRealOfComplex,V_FPImagOfComplex) -> unitM (s1,s2)
	       | (V_FPImagOfComplex,V_FPRealOfComplex) -> unitM (s2,s1)
	       | _ -> failM) 
	    >>= fun fuse_pair ->
	      fuseSrcM fuse_pair >>= fun (s_simd,dvects) ->
	        addSimdInstrM (V_SimdStore2(s_simd,d1_arr,d1_idx)) >>= fun _ ->
		  unitM dvects
      | _ -> failM

(****************************************************************************)

let rec vectorizeScalarInstr2M' d_simd ids instrs =
  vectorizeScalarInstr2M d_simd ids instrs >>= fun (dvects, new_visited) ->
    iterM addToVisitedM new_visited >>= fun _ ->
      unitM dvects

and vectorizeScalarInstr2M d_simd (re_id,im_id) = function
  | V_FPUnaryOp(op1,s1,d1), V_FPUnaryOp(op2,s2,d2) -> 
      unaryoppairToSimdunaryopM (op1,op2) >>= fun simd_op ->
        fuseSrcM (s1,s2) >>= fun (s_simd,dvects) ->
          addSimdInstrM (V_SimdUnaryOp(simd_op,s_simd,d_simd)) >>= fun _ ->
	    unitM (dvects, [re_id; im_id])

  | instrL, V_FPUnaryOp(op,s2,d2) ->
      let s1  = optionToValue (vfpinstrToDstreg instrL)
      and op' = scalarvfpunaryopToVsimdunaryop op V_ChsHi in
        addFpFuseM s1 s2 >>= fun (d_simd',dvects) -> 
	  addSimdInstrM (V_SimdUnaryOp(op', d_simd', d_simd)) >>= fun _ ->
	    unitM (dvects, [im_id])

  | V_FPUnaryOp(op,s1,d1), instrR ->
      let s2  = optionToValue (vfpinstrToDstreg instrR)
      and op' = scalarvfpunaryopToVsimdunaryop op V_ChsLo in
	addFpFuseM s1 s2 >>= fun (d_simd',dvects) -> 
	  addSimdInstrM (V_SimdUnaryOp(op', d_simd', d_simd)) >>= fun _ ->
	    unitM (dvects, [re_id])

  | V_FPBinaryOp(op1,s1,t1,d1), V_FPBinaryOp(op2,s2,t2,d2) ->
      let src_info = (s1,t1,s2,t2) in
        binoppairToVectfnM (op1,op2) >>= fun (fuse_fn,addinstr_fn) ->
	  fuse_fn src_info >>= fun ((x_simd,x_instrs), (y_simd,y_instrs)) ->
	    addinstr_fn d_simd (x_simd, y_simd) >>= fun _ ->
	      unitM (x_instrs @ y_instrs, [re_id; im_id])

  | V_FPAddL(s1,d1), V_FPAddL(s2,d2) ->
      iterM addToVisitedM [re_id; im_id] >>= fun _ -> (* earlier is better? *)
	(if length s2 < 3 then unitM s2 else permutationM s2) >>= fun s2p -> 
	  vectorizeAddListM (d_simd,d1,d2) (s1,s2p) >>= fun (dvs,s1',s2') ->
	    if vfpsummandIsPositive s1' && vfpsummandIsPositive s2' then
	      unitM (dvs, [])
	    else
	      failwith "vectorizeScalarInstr2M: inconsistent addlist-result"

  | (V_FPLoad(s1_access,s1_arr,s1_idx,d1), 
     V_FPLoad(s2_access,s2_arr,s2_idx,d2)) ->
      vectorizeLoadM (s1_access,s1_arr,s1_idx,d1)
		     (s2_access,s2_arr,s2_idx,d2) >>= fun dvects ->
        unitM (dvects, [re_id; im_id])

  | _ ->
      failM

(****************************************************************************)

(* [precondition:] List.length xs = List.length zs *)
and vectorizeAddListM ((d_simd,d_re,d_im) as d) = function 
  | [], [] -> failwith "vectorizeAddListM: listlength = 0 not supported!"
  | [x'], [z'] -> 
	unitM ([],x', z')
  | [x1';x2'], [z1';z2'] ->
      let (i1,d_re') = addlistHelper2 d_re (x1',x2') 
      and (i2,d_im') = addlistHelper2 d_im (z1',z2') in
	let id_1 = Id.makeNew ()		(* this sucks *)
	and id_2 = Id.makeNew () in
        vectorizeScalarInstr2M' d_simd (id_1,id_2) (i1,i2) >>= fun dvects ->
	  unitM (dvects,d_re', d_im')
  | xs, zs ->
      let xs_l, xs_r = zip xs in
      let zs_l, zs_r = zip zs in
	fuseNewM () >>= fun ((d_l_simd,d_l_re,d_l_im) as d_l) ->
	fuseNewM () >>= fun ((d_r_simd,d_r_re,d_r_im) as d_r) ->
          vectorizeAddListM d_l (xs_l,zs_l) >>= fun (dvs1,d_l_re', d_l_im') ->
	  vectorizeAddListM d_r (xs_r,zs_r) >>= fun (dvs2,d_r_re', d_r_im') ->
	    vectorizeAddListM d ([d_l_re'; d_r_re'], [d_l_im'; d_r_im']) 
	    >>= fun (dvs3, ret1, ret2) ->
	      unitM (dvs1@dvs2@dvs3, ret1, ret2)

(****************************************************************************)

and vectorizeScalarInstrM me_id here_instr = match here_instr with
  | V_FPStore _ as this_store ->
      addToVisitedM me_id >>= fun _ ->
	getUnvisitedStoreM () >>= fun (other_id,other_store) ->
	  posAssertM (currentvectgradeAllowsPairing 
				(this_store,other_store)) >>= fun _ ->
	  (match (this_store,other_store) with
	     | (V_FPStore(s1,d1_access,d1_arr,d1_idx), 
	        V_FPStore(s2,d2_access,d2_arr,d2_idx)) ->
		  vectorizeStoreM (s1,d1_access,d1_arr,d1_idx)
				  (s2,d2_access,d2_arr,d2_idx)

	     | _ -> failwith "fpstore inconsistent!")

  | V_FPLoad _ as this_load ->
      addToVisitedM me_id >>= fun _ ->
	getUnvisitedLoadM () >>= fun (other_id,other_load) ->
	  posAssertM (currentvectgradeAllowsPairing 
			(this_load,other_load)) >>= fun _ ->
	    (match (this_load,other_load) with
	       | (V_FPLoad(s1_access,s1_arr,s1_idx,d1), 
		  V_FPLoad(s2_access,s2_arr,s2_idx,d2)) ->
	            vectorizeLoadM (s1_access,s1_arr,s1_idx,d1)
			           (s2_access,s2_arr,s2_idx,d2) >>= fun _ -> 
		      unitM []
	       | _ -> failwith "fpload inconsistent!")

  | instr ->
      failwith "vectorizeScalarInstrM: SingleVect(Any) is not supported!"

and vectorize2M = function
  | SingleVect((i_id,i_instr)) ->
      fetchVisitedM >>= fun visited ->
        if IdSet.mem i_id visited then
          unitM []
        else
          vectorizeScalarInstrM i_id i_instr
  | DualVect(d_simd,((i1_id,i1_instr) as i1_info),
		    ((i2_id,i2_instr) as i2_info)) ->
      fetchVisitedM >>= fun visited ->
	(match (IdSet.mem i1_id visited, IdSet.mem i2_id visited) with
	   | (true, true) -> unitM []
	   | (false, false) ->
	       vectorizeScalarInstr2M 
			d_simd 
			(i1_id,i2_id) 
			(i1_instr,i2_instr) 
	       >>= fun (dvects, newvisited) ->
		 iterM addToVisitedM newvisited >>= fun _ ->
		   unitM dvects
	   | (false,true)
	   | (true, false) ->
	       failM)

and vectorizeM = function
  | [] -> unitM () 
  | x::xs ->
      incr_vect_steps ();
	vectorize2M x >>= 
	(* In some cases it may be favorable to reorder instructions, ie.,
	 * to delay the vectorization of expensive instruction (addList).
 	 *
	 * This is *not* done at the moment, however. 
	 *)
	  vectorizeM >>= fun _ -> 
	    vectorizeM xs

(****************************************************************************)

let arrayHasInterleavedcomplexformat arr info = match listAssoc arr info with
  | Some(ComplexArray(InterleavedFormat)) -> true
  | _ -> false

let checkVectgradeRequirementsM all_instrs grade =
  posAssertM (count vfpinstrIsStore all_instrs mod 2 = 0) >>= fun _ ->
    (match grade with
      | VECTGRADE_FULL ->
	  let nr_addsubs = sum_list (map vfpinstrToAddsubcount all_instrs)
	  and nr_muls = count vfpinstrIsBinMul all_instrs 
	  and nr_unaryops = count vfpinstrIsUnaryOp all_instrs 
	  and nr_loads = count vfpinstrIsLoad all_instrs in
	    posAssertM (nr_addsubs mod 2 = 0 &&
			nr_muls mod 2 = 0 &&
			nr_unaryops mod 2 = 0 &&
			nr_loads mod 2 = 0))

let fn_sets = 
  [
   ("2N vectorization",   addAdd_Set1, addSub_Set1, subAdd_Set1, subSub_Set1);
   ("2N+1 vectorization", addAdd_Set1, addSub_Set1, subAdd_Set2, subSub_Set1);
   ("3N vectorization",   addAdd_Set2, addSub_Set2, subAdd_Set2, subSub_Set2);
   ("3N+1 vectorization", addAdd_Set3, addSub_Set3, subAdd_Set3, subSub_Set3);
  ]

let vectorizeGradedM all_instrs xs = 
  memberM vectorization_grades >>= fun grade ->
    checkVectgradeRequirementsM all_instrs grade >>= fun _ ->
      memberM fn_sets >>= fun (fnsettext,addadd,addsub,subadd,subsub) ->
      let _ = 
	begin
	  info (Printf.sprintf "trying grade: %s (%s)" 
			       (vectorizationgradeToString grade)
			       fnsettext);

	  vectFp_AddAdd_Fns := addadd; 
	  vectFp_AddSub_Fns := addsub;
	  vectFp_SubAdd_Fns := subadd;
	  vectFp_SubSub_Fns := subsub;

	  current_vectorization_grade := grade;
          vect_steps := 0
	end in
          catch1M 
		OutOfTime 
		(fun _ -> info "vectorization terminated (TIMEOUT)"; failM) >>= fun _ ->
	    vectorizeM xs >>= fun _ ->
	      fetchSimdInstrsM >>= fun vectorized_instrs' ->
	        unitM vectorized_instrs'
 
(****************************************************************************)

let rec calc_min_depths depthmap writers xs =
  List.fold_right (fun i s0 -> calc_min_depth s0 writers i) xs depthmap

and calc_min_depth depthmap writers (id,instr) =
  if idmap_exists id depthmap then
    depthmap
  else
    calc_min_depth' depthmap writers (id,instr)

and calc_min_depth' depthmap writers (id,instr) =
  let srcs = vfpinstrToSrcregs instr in
  let srcs_writers = List.map (fun src -> VFPRegMap.find src writers) srcs in
  let depthmap' = calc_min_depths depthmap writers srcs_writers in
  let vals = List.map (fun (id,_) -> IdMap.find id depthmap') srcs_writers in
  let minval = if vals = [] then 0 else min_list vals in
    IdMap.add id (succ minval) depthmap'

(***************************************************************************)

let vectorize' varinfo n vinstrs =
  let vinstrs' = map (fun i -> (Id.makeNew (),i)) vinstrs in
  let (loads,other') = partition (fun (_,i) -> vfpinstrIsLoad i) vinstrs' in
  let (stores,_) = partition (fun (_,i) -> vfpinstrIsStore i) other' in
  let writers = 
	fold_right
		(fun ((i_id,i_instr) as i) ->
		   match vfpinstrToDstreg i_instr with
		     | None   -> return
		     | Some d -> VFPRegMap.add d i)
		vinstrs'
		VFPRegMap.empty in
  let depths = calc_min_depths IdMap.empty writers stores in
    runM (vectorizeGradedM vinstrs) 
	 (map (fun p -> SingleVect p) stores) 
         (varinfo,IdSet.empty,VFPRegMap.empty,[],(loads,stores,writers),depths)

(***************************************************************************)

let vectorize varinfo n vinstrs =
  info "vectorize: trying cheap vectorization";
  transformlength := n;
  let vinstrs' = concat (map fullyexpandaddlistVfpinstr vinstrs) in
    match vectorize' varinfo n vinstrs' with
      | Some(instrs,_) -> 
	  info (Printf.sprintf
			"cheap-mode: %s succeeded. (%d steps)"
			(vectorizationgradeToString 
				!current_vectorization_grade)
			!vect_steps);
	  instrs
      | None ->
	  info "vectorize: trying $$$ vectorization";
	  match vectorize' varinfo n vinstrs with
	    | Some(instrs,_) -> 
		info (Printf.sprintf
			"$$$-mode: %s succeeded (%d steps)"
			(vectorizationgradeToString 
				!current_vectorization_grade)
			!vect_steps);
		instrs
	    | None -> 
		failwith "vectorization failed"
