content: {-# LANGUAGE GADTs #-}
  module Analysis where
  
  import Compiler.Hoopl
  import Control.Monad.State
  
  type Addr = Int
  
  data StackIL = Dup | Ld Addr Type | Add Type | Store Addr Type deriving Show
  
  type Target = (Int,Type)
  type Source = (Int,Type)
  
  tmpReg = 10
  
  data RegIL = RMov Target Source | RAdd Target Source Source 
               | RStore Addr Source | RLoad Source Addr deriving Show
  
  data Type = Int | Bottom deriving (Show,Eq)
  
  type StackElem = (Int,Type)
  
  type Stack = [StackElem]
  
  dup :: State Stack ()
  dup = modify (\(top@(i,t):xs) -> (i+1,t) : top : xs)
  
  push :: Type -> State Stack Int
  push t = do tos <- get
              case tos of 
                top@(i,_):xs -> put ((i + 1, t) : top : xs) >> return i
                [] -> put [(0,t)] >> return 0 
  
  pop :: State Stack StackElem
  pop = do x:xs <- get
           put xs
           return x
  
  nextElem :: State Stack Int
  nextElem = fmap ((+ 1) . fst . head) get
  
  aInterpret' :: StackIL -> State Stack [RegIL]
  aInterpret' Dup = dup >> return []
  aInterpret' (Ld addr t) = do s <- push t
                               return [RLoad (s,t) addr]
  aInterpret' (Store addr t) = do (xA,tA) <- pop 
                                  return [RStore addr (xA,tA)]
  aInterpret' (Add t) = do (iA,ta) <- pop
                           (iB,tb) <- pop 
                           push ta
                           if ta /= t || tb /=t then error "type mismatch in add"
                              else return [ RAdd (tmpReg,ta) (iA,ta) (iB,tb), 
                                            RMov (iB,tb) (tmpReg,ta)]
  
  aInterpret :: [StackIL] -> State Stack [RegIL]
  aInterpret = foldr (liftM2 (++) . aInterpret') (return [])
  
  generateRegisterIR :: [StackIL] -> [RegIL]
  generateRegisterIR = (`evalState` []) . aInterpret
  
  --data StackIL = Dup | Ld Addr Type | Add Type | Store Addr Type
  testCase1 =  [ Ld 0 Int, Ld 1 Int, Dup , Add Int, Add Int, Store 0 Int]
  
  bench = concat . replicate 100000 
  
  type TLabel = Int
  type Var = String
  data Expr = VarE Var | AddE Var Var | Lit Int | CLe Expr Expr
  
  data Node e x where
    Label  :: TLabel -> Node C O
    Assign :: Var -> Expr -> Node O O
    If :: Expr -> TLabel -> TLabel -> Node O C
    Ret :: Node O C
    Nop :: Node O O
    Branch :: TLabel -> Node C C
  
  {-testProgram = [ Assign "x" (Lit 3),
                  Assign "y" (Lit 5),  
                  If (CLe (VarE "x") (VarE "y")) 1 2,
                  Assign "x" (VarE "y")
                  ] -}
  
  
  