--------------------------------------------------------------------------------
-- Copyright 2001-2012, Daan Leijen, Bastiaan Heeren, Jurriaan Hage. This file 
-- is distributed under the terms of the BSD3 License. For more information, 
-- see the file "LICENSE.txt", which is included in the distribution.
--------------------------------------------------------------------------------
--  $Id: Rewrite.hs 291 2012-11-08 11:27:33Z heere112 $

module Lvm.Instr.Rewrite (instrRewrite) where

import Lvm.Instr.Data

{---------------------------------------------------------------
  debugging
---------------------------------------------------------------}

{-
showInstr instr
  = showInstrs [instr]

showInstrs instrs
  = show (instrPretty instrs)


traceInstrs instrs 
  = trace ("trace:\n" ++ showInstrs instrs ++ "\n\n") instrs 
  -}

{---------------------------------------------------------------
  rewrite rules
---------------------------------------------------------------}
instrRewrite :: [Instr] -> [Instr]
instrRewrite instrs
  = peephole (rewrites (dummies (rewrites (rewrites instrs))))

rewrites :: [Instr] -> [Instr]
rewrites instrs
  = case instrs of  
      -- TODO: the following three rules optimize things like (id x = x) but
      -- this can probably be better done on the code generation level
      PUSHVAR (Var _ 0 _) : SLIDE 1 m d : is
        | m >= 1
        -> rewrites (SLIDE 1 (m-1) (d-1) : is)

      PUSHVAR (Var _ 1 _) : PUSHVAR (Var _ 1 _) : SLIDE 2 m d : is
        | m >= 2
        -> rewrites (SLIDE 2 (m-2) (d-2) : is)

      PUSHVAR (Var _ 2 _) : PUSHVAR (Var _ 2 _) : PUSHVAR (Var _ 2 _) : SLIDE 3 m d : is
        | m >= 3
        -> rewrites (SLIDE 3 (m-3) (d-3) : is)
           
      -- applications
      NEWAP i : SLIDE n m d: ENTER : is
        -> SLIDE (n+i-1) m (d+i-1): ENTER : rewrites is

      NEWNAP i : SLIDE n m d: ENTER : is
        -> SLIDE (n+i-1) m (d+i-1): ENTER : rewrites is

      CALL global : SLIDE 1 m d: ENTER : is
        -> SLIDE arity m (d+arity-1): CALL global : ENTER : rewrites is
        where
          arity = arityFromGlobal global

      -- returns
      NEWCON con : SLIDE 1 m d: ENTER : is
        -> SLIDE n m (d+n-1): RETURNCON con : rewrites is
        where n = arityFromCon con

      PUSHINT i : SLIDE 1 m d: ENTER : is
        -> SLIDE 0 m (d-1): RETURNINT i : rewrites is

      instr : SLIDE 1 m d: ENTER : is
        | strictResult instr
        -> instr : SLIDE 1 m d: RETURN : is

      -- eval and pushcode
      PUSHCODE f : is
        -> rewritePushCode f (rewrites is)

      EVAL d is' : is
        -> rewriteEval d (rewrites is') is

      -- merge slides
      SLIDE n0 m0 d0 : SLIDE n1 m1 _ : is
        | n1 <= n0  -> rewrites (SLIDE n1 (m0+m1-(n0-n1)) d0 : is)

      -- essential rewrites
      MATCH alts : is
        -> [rewriteMatch MATCH alts is]

      MATCHCON alts : is
        -> [rewriteMatch MATCHCON alts is]

      SWITCHCON alts : is
        -> [rewriteMatch SWITCHCON alts is]

      MATCHINT alts : is
        -> [rewriteMatch MATCHINT alts is]

      -- default
      instr:rest    -> instr:rewrites rest
      []            -> []


rewriteMatch :: ([Alt] -> a) -> [Alt] -> [Instr] -> a
rewriteMatch match alts is = match (map (rewriteAlt is) alts)

rewriteAlt :: [Instr] -> Alt -> Alt
rewriteAlt instrs (Alt pat is)
   | null is   = Alt pat []
   | otherwise = Alt pat (rewrites (is ++ instrs))

-- rewrite PUSHCODE
rewritePushCode :: Global -> [Instr] -> [Instr]
rewritePushCode f instrs
  = case instrs of
      NEWAP n : is
        | arity >= n -> PUSHCODE f : NEWNAP n : is
      PACKAP var n : is
        | arity >= n -> PUSHCODE f : PACKNAP var n : is
      SLIDE n m d: ENTER : is
        | arity == (n-1) && arity /= 0  -> SLIDE (n-1) m (d-1): ENTERCODE f : is
      _
        -> PUSHCODE f  : instrs
  where
    arity = arityFromGlobal f

-- rewrite EVAL
rewriteEval :: Depth -> [Instr] -> [Instr] -> [Instr]
rewriteEval d evalis is
  =  case evalis of
       [PUSHVAR (Var x ofs d1),SLIDE 1 0 _,ENTER]
          -> rewrites (EVALVAR (Var x (ofs-3) d1) : is)
       [PUSHVAR (Var x ofs dv),ENTER]
          -> rewrites (EVALVAR (Var x (ofs-3) dv) : is)
       _  -> EVAL d evalis : rewrites is

{---------------------------------------------------------------
  peephole optimization
---------------------------------------------------------------}

peephole :: [Instr] -> [Instr]
peephole = simplify shorten

dummies :: [Instr] -> [Instr]
dummies = simplify id

simplify :: (Instr -> Instr) -> [Instr] -> [Instr]
simplify single = walk
  where
    walk instrs 
      = case instrs of
          -- structured
          EVAL d is' : is           -> EVAL d (walk is') : walk is
          MATCH alts : is           -> MATCH (map walkAlt alts)  : walk is
          MATCHCON alts : is        -> MATCHCON (map walkAlt alts)  : walk is
          SWITCHCON alts : is       -> SWITCHCON (map walkAlt alts)  : walk is
          MATCHINT alts : is        -> MATCHINT (map walkAlt alts)  : walk is

          -- dummy
          NEWAP 1 : is              -> walk is
          NEWNAP 1 : is             -> walk is

          -- slide
          SLIDE _ 0 _ : is          -> walk is
          SLIDE 1 _ _ : RETURN : is -> walk (RETURN : is)
          SLIDE n _ _ : RETURNCON con : is
                                    | arityFromCon con == n -> walk (RETURNCON con : is)
          SLIDE 0 _ _ : RETURNINT i : is
                                    -> walk (RETURNINT i : is)

          -- shorten sequences
          PUSHVAR v : PUSHVAR w : is
                                    -> PUSHVARS2 v w : walk is

          -- default
          instr:is                  -> single instr : walk is
          []                        -> []

    walkAlt (Alt pat is)
      = Alt pat (walk is)

shorten :: Instr -> Instr
shorten instr
  = case instr of
      PUSHVAR var   -> case offsetFromVar var of
                         0     -> PUSHVAR0
                         1     -> PUSHVAR1
                         2     -> PUSHVAR2
                         3     -> PUSHVAR3
                         4     -> PUSHVAR4
                         _     -> instr

      NEWAP n       -> case n of
                         2     -> NEWAP2
                         3     -> NEWAP3
                         4     -> NEWAP4
                         _     -> instr

      NEWNAP n      -> case n of
                         2     -> NEWNAP2
                         3     -> NEWNAP3
                         4     -> NEWNAP4
                         _     -> instr

      NEWCON con    -> case arityFromCon con of
                         0     -> NEWCON0 con
                         1     -> NEWCON1 con
                         2     -> NEWCON2 con
                         3     -> NEWCON3 con
                         _     -> instr

      RETURNCON con -> case arityFromCon con of
                         0     -> RETURNCON0 con
                         _     -> instr

      _             -> instr