Module Constprop

Require Import Coqlib Maps Integers Floats Lattice Kildall.
Require Import AST Linking.
Require Compopts Machregs.
Require Import Op Registers RTL.
Require Import Liveness ValueDomain ValueAOp ValueAnalysis.
Require Import ConstpropOp.


Definition transf_ros (ae: AE.t) (ros: reg + ident) : reg + ident :=
  match ros with
  | inl r =>
      match areg ae r with
      | Ptr(Gl symb ofs) => if Ptrofs.eq ofs Ptrofs.zero then inr _ symb else ros
      | _ => ros
      end
  | inr s => ros
  end.

Fixpoint successor_rec (n: nat) (f: function) (ae: AE.t) (pc: node) : node :=
  match n with
  | O => pc
  | S n' =>
      match f.(fn_code)!pc with
      | Some (Inop s) =>
          successor_rec n' f ae s
      | Some (Icond cond args s1 s2) =>
          match resolve_branch (eval_static_condition cond (aregs ae args)) with
          | Some b => successor_rec n' f ae (if b then s1 else s2)
          | None => pc
          end
      | _ => pc
      end
  end.

Definition num_iter := 10%nat.

Definition successor (f: function) (ae: AE.t) (pc: node) : node :=
  successor_rec num_iter f ae pc.

Fixpoint builtin_arg_reduction (ae: AE.t) (a: builtin_arg reg) :=
  match a with
  | BA r =>
      match areg ae r with
      | I n => BA_int n
      | L n => BA_long n
      | F n => if Compopts.generate_float_constants tt then BA_float n else a
      | FS n => if Compopts.generate_float_constants tt then BA_single n else a
      | _ => a
      end
  | BA_splitlong hi lo =>
      match builtin_arg_reduction ae hi, builtin_arg_reduction ae lo with
      | BA_int nhi, BA_int nlo => BA_long (Int64.ofwords nhi nlo)
      | hi', lo' => BA_splitlong hi' lo'
      end
  | _ => a
  end.

Definition builtin_arg_strength_reduction
      (ae: AE.t) (a: builtin_arg reg) (c: builtin_arg_constraint) :=
  let a' := builtin_arg_reduction ae a in
  if builtin_arg_ok a' c then a' else a.

Fixpoint builtin_args_strength_reduction
      (ae: AE.t) (al: list (builtin_arg reg)) (cl: list builtin_arg_constraint) :=
  match al with
  | nil => nil
  | a :: al =>
      builtin_arg_strength_reduction ae a (List.hd OK_default cl)
      :: builtin_args_strength_reduction ae al (List.tl cl)
  end.


Fixpoint debug_strength_reduction (ae: AE.t) (al: list (builtin_arg reg)) :=
  match al with
  | nil => nil
  | a :: al =>
      let a' := builtin_arg_reduction ae a in
      let al' := a :: debug_strength_reduction ae al in
      match a, a' with
      | BA _, (BA_int _ | BA_long _ | BA_float _ | BA_single _) => a' :: al'
      | _, _ => al'
      end
  end.

Definition builtin_strength_reduction
             (ae: AE.t) (ef: external_function) (al: list (builtin_arg reg)) :=
  match ef with
  | EF_debug _ _ _ => debug_strength_reduction ae al
  | _ => builtin_args_strength_reduction ae al (Machregs.builtin_constraints ef)
  end.

Definition transf_instr (f: function) (an: PMap.t VA.t) (rm: romem)
                        (pc: node) (instr: instruction) :=
  match an!!pc with
  | VA.Bot =>
      instr
  | VA.State ae am =>
      match instr with
      | Iop op args res s =>
          let aargs := aregs ae args in
          let a := eval_static_operation op aargs in
          let s' := successor f (AE.set res a ae) s in
          match const_for_result a with
          | Some cop =>
              Iop cop nil res s'
          | None =>
              let (op', args') := op_strength_reduction op args aargs in
              Iop op' args' res s'
          end
      | Iload chunk addr args dst s =>
          let aargs := aregs ae args in
          let a := ValueDomain.loadv chunk rm am (eval_static_addressing addr aargs) in
          match const_for_result a with
          | Some cop =>
              Iop cop nil dst s
          | None =>
              let (addr', args') := addr_strength_reduction addr args aargs in
              Iload chunk addr' args' dst s
          end
      | Istore chunk addr args src s =>
          let aargs := aregs ae args in
          let (addr', args') := addr_strength_reduction addr args aargs in
          Istore chunk addr' args' src s
      | Icall sig ros args res s =>
          Icall sig (transf_ros ae ros) args res s
      | Itailcall sig ros args =>
          Itailcall sig (transf_ros ae ros) args
      | Ibuiltin ef args res s =>
          Ibuiltin ef (builtin_strength_reduction ae ef args) res s
      | Icond cond args s1 s2 =>
          let aargs := aregs ae args in
          match resolve_branch (eval_static_condition cond aargs) with
          | Some b =>
              if b then Inop s1 else Inop s2
          | None =>
              let (cond', args') := cond_strength_reduction cond args aargs in
              Icond cond' args' s1 s2
          end
      | Ijumptable arg tbl =>
          match areg ae arg with
          | I n =>
              match list_nth_z tbl (Int.unsigned n) with
              | Some s => Inop s
              | None => instr
              end
          | _ => instr
          end
      | _ =>
          instr
      end
  end.

Definition transf_function (rm: romem) (f: function) : function :=
  let an := ValueAnalysis.analyze rm f in
  mkfunction
    f.(fn_sig)
    f.(fn_params)
    f.(fn_stacksize)
    (PTree.map (transf_instr f an rm) f.(fn_code))
    f.(fn_entrypoint).

Definition transf_fundef (rm: romem) (fd: fundef) : fundef :=
  AST.transf_fundef (transf_function rm) fd.

Section WITHROMEMFOR.
Context `{romem_for_instance: ROMemFor}.

Definition transf_program (p: program) : program :=
  let rm := romem_for p in
  transform_program (transf_fundef rm) p.

End WITHROMEMFOR.