{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module Synthesizer.LLVM.Filter.SecondOrderCascade where

import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2
import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core

import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP

import qualified Synthesizer.LLVM.Frame.SerialVector as Serial

import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Extra.Class as Class
import qualified LLVM.Extra.ScalarOrVector as SoV
import qualified LLVM.Extra.Memory as Memory
import LLVM.Extra.Class (Undefined, undefTuple, )

import qualified LLVM.Core as LLVM
import LLVM.Util.Loop (Phi, phis, addPhis, )
import LLVM.Core
   (Value, valueOf,
    IsArithmetic, IsSized,
    CodeGenFunction, )

import qualified Types.Data.Bool as TypeBool
import qualified Types.Data.Num as TypeNum
import Types.Data.Num.Ops ((:*:), )

import Data.Word (Word32, )

import qualified Control.Arrow as Arrow
import Control.Arrow ((>>>), (<<<), (&&&), arr, )

-- import qualified Algebra.Transcendental as Trans
-- import qualified Algebra.Field as Field
-- import qualified Algebra.Module as Module
-- import qualified Algebra.Ring as Ring

import NumericPrelude.Numeric
import NumericPrelude.Base


type ParameterStruct n a = LLVM.Array n (Filt2.ParameterStruct a)

newtype ParameterValue n a =
   ParameterValue {parameterValue :: Value (ParameterStruct n a)}
{-
Automatic deriving is not allowed even with GeneralizedNewtypeDeriving
because of IsSized constraint
and it would also be wrong for Functor and friends.
      deriving
         (Phi, Class.Undefined, Class.Zero,
          Functor, App.Applicative, Fold.Foldable, Trav.Traversable)
-}

instance (TypeNum.NaturalT n, IsSized a) =>
      Phi (ParameterValue n a) where
   phis bb (ParameterValue r) =
      fmap ParameterValue $ phis bb r
   addPhis bb
        (ParameterValue r)
        (ParameterValue r') =
      addPhis bb r r'

instance (TypeNum.NaturalT n, IsSized a) =>
      Class.Undefined (ParameterValue n a) where
   undefTuple = ParameterValue Class.undefTuple

instance (TypeNum.NaturalT n, IsSized a) =>
      Class.Zero (ParameterValue n a) where
   zeroTuple = ParameterValue Class.zeroTuple

instance (TypeNum.IntegerT n, TypeNum.IsNatural n ~ TypeBool.True,
          Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am,
          TypeNum.PositiveT (n :*: LLVM.UnknownSize)) =>
      Memory.C (ParameterValue n a) where
   type Struct (ParameterValue n a) = ParameterStruct n (Memory.Stored a)
   load = Memory.loadNewtype ParameterValue
   store = Memory.storeNewtype (\(ParameterValue k) -> k)
   decompose = Memory.decomposeNewtype ParameterValue
   compose = Memory.composeNewtype (\(ParameterValue k) -> k)



withSize ::
   (n -> CausalP.T p (ParameterValue n a, x) y) ->
   CausalP.T p (ParameterValue n a, x) y
withSize f = f undefined

fixSize ::
   n ->
   CausalP.T p (ParameterValue n a, x) y ->
   CausalP.T p (ParameterValue n a, x) y
fixSize _n = id

causalP ::
   (A.PseudoModule (LLVM.Value a) v,
    Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am,
    Memory.C v,
    IsArithmetic a, SoV.IntegerConstant a, TypeNum.NaturalT n,
    TypeNum.PositiveT (n :*: LLVM.UnknownSize)) =>
   CausalP.T p (ParameterValue n a, v) v
causalP =
   withSize $ \n ->
   foldl (\x y -> (arr fst &&& x) >>> y) (arr snd) $
   map
      (\k ->
         Filt2.causalP <<<
         Arrow.first (CausalP.mapSimple
            (\ps -> getStageParameter ps k)))
      (take (TypeNum.fromIntegerT n) [0..])

causalPackedP ::
   (A.PseudoModule (LLVM.Value a) v,
    Serial.C v, Serial.Element v ~ LLVM.Value a,
    SoV.IntegerConstant a,
    A.PseudoRing v, A.IntegerConstant v, Memory.C v,
    Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am,
    LLVM.IsPrimitive a,
    LLVM.IsPrimitive am,
    TypeNum.PositiveT (n :*: LLVM.UnknownSize),
    TypeNum.NaturalT n) =>
   CausalP.T p (ParameterValue n a, v) v
causalPackedP =
   withSize $ \n ->
   foldl (\x y -> (arr fst &&& x) >>> y) (arr snd) $
   map
      (\k ->
         Filt2.causalPackedP <<<
         Arrow.first (CausalP.mapSimple
            (\ps -> getStageParameter ps k)))
      (take (TypeNum.fromIntegerT n) [0..])

getStageParameter, getStageParameterMalloc, getStageParameterAlloca ::
   (LLVM.IsFirstClass a, IsSized a, SoV.IntegerConstant a,
    TypeNum.NaturalT n, TypeNum.PositiveT (n :*: LLVM.UnknownSize)) =>
   ParameterValue n a ->
   Word32 ->
   CodeGenFunction r (Filt2Core.Parameter (Value a))
getStageParameter ps k =
   Filt2.decomposeParameter =<< LLVM.extractvalue (parameterValue ps) k
{-
   Memory.decompose =<<
   flip LLVM.extractvalue k =<<
   Memory.compose ps
-}

{-
Expensive because we need a heap allocation for every sample.
However, we could allocate the memory once in the Causal initialization routine.
-}
getStageParameterMalloc ps k = do
   ptr <- LLVM.malloc
   LLVM.store (parameterValue ps) ptr
   p <-
      Filt2.decomposeParameter
       =<< LLVM.load
       =<< LLVM.getElementPtr0 ptr (valueOf k, ())
   LLVM.free ptr
   return p

{-
With this implementation, LLVM-2.6 generates a stack variable layout
that requires non-aligned access to vector values.
The result is a crash at runtime.
-}
getStageParameterAlloca ps k = do
   ptr <- LLVM.alloca
   LLVM.store (parameterValue ps) ptr
   Filt2.decomposeParameter
    =<< LLVM.load
    =<< LLVM.getElementPtr0 ptr (valueOf k, ())