{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module LLVM.Util.Loop(Phi(phis,addPhis), forLoop, mapVector, mapVector2) where

import LLVM.Core
import qualified Type.Data.Num.Decimal.Number as Dec


class Phi a where
    phis :: BasicBlock -> a -> CodeGenFunction r a
    addPhis :: BasicBlock -> a -> a -> CodeGenFunction r ()

{-
infixr 1 :*
-- XXX should use HList if it was packaged in a nice way.
data a :* b = a :* b
    deriving (Eq, Ord, Show, Read)

instance (IsFirstClass a, Phi b) => Phi (Value a :* b) where
    phis bb (a :* b) = do
        a' <- phi [(a, bb)]
        b' <- phis bb b
        return (a' :* b')
    addPhis bb (a :* b) (a' :* b') = do
        addPhiInputs a [(a', bb)]
        addPhis bb b b'
-}

instance Phi () where
    phis _ _ = return ()
    addPhis _ _ _ = return ()

instance (IsFirstClass a) => Phi (Value a) where
    phis bb a = do
        a' <- phi [(a, bb)]
        return a'
    addPhis bb a a' = do
        addPhiInputs a [(a', bb)]

instance (Phi a, Phi b) => Phi (a, b) where
    phis bb (a, b) = do
        a' <- phis bb a
        b' <- phis bb b
        return (a', b')
    addPhis bb (a, b) (a', b') = do
        addPhis bb a a'
        addPhis bb b b'

instance (Phi a, Phi b, Phi c) => Phi (a, b, c) where
    phis bb (a, b, c) = do
        a' <- phis bb a
        b' <- phis bb b
        c' <- phis bb c
        return (a', b', c')
    addPhis bb (a, b, c) (a', b', c') = do
        addPhis bb a a'
        addPhis bb b b'
        addPhis bb c c'

-- Loop the index variable from low to high.  The state in the loop starts as start, and is modified
-- by incr in each iteration.
forLoop :: forall i a r . (Phi a, Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i, CmpResult i ~ Bool) =>
           Value i -> Value i -> a -> (Value i -> a -> CodeGenFunction r a) -> CodeGenFunction r a
forLoop low high start incr = do
    top <- getCurrentBasicBlock
    loop <- newBasicBlock
    body <- newBasicBlock
    exit <- newBasicBlock

    br loop

    defineBasicBlock loop
    i <- phi [(low, top)]
    vars <- phis top start
    t <- cmp CmpNE i high
    condBr t body exit

    defineBasicBlock body

    vars' <- incr i vars
    i' <- add i (valueOf 1 :: Value i)

    body' <- getCurrentBasicBlock
    addPhis body' vars vars'
    addPhiInputs i [(i', body')]
    br loop
    defineBasicBlock exit

    return vars

--------------------------------------

mapVector :: forall a b n r .
             (Dec.Positive n, IsPrimitive b) =>
             (Value a -> CodeGenFunction r (Value b)) ->
             Value (Vector n a) -> CodeGenFunction r (Value (Vector n b))
mapVector f v =
    forLoop (valueOf 0) (valueOf (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n))) (value undef) $ \ i w -> do
        x <- extractelement v i
        y <- f x
        insertelement w y i

mapVector2 :: forall a b c n r .
             (Dec.Positive n, IsPrimitive c) =>
             (Value a -> Value b -> CodeGenFunction r (Value c)) ->
             Value (Vector n a) -> Value (Vector n b) -> CodeGenFunction r (Value (Vector n c))
mapVector2 f v1 v2 =
    forLoop (valueOf 0) (valueOf (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n))) (value undef) $ \ i w -> do
        x <- extractelement v1 i
        y <- extractelement v2 i
        z <- f x y
        insertelement w z i