{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{- |
Data type that allows handling of piecewise constant signals
independently from the source.
-}
module Synthesizer.LLVM.ConstantPiece (
   T(..),
   Struct,
   parameterMemory,
   flatten,
   causalMap,
   ) where

import qualified Synthesizer.LLVM.Causal.Private as Causal
import qualified Synthesizer.LLVM.Generator.Private as Sig

import qualified LLVM.DSL.Expression as Expr

import qualified LLVM.Extra.MaybeContinuation as Maybe
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Tuple as Tuple
import qualified LLVM.Extra.Arithmetic as A
import LLVM.Extra.Control (whileLoop)

import qualified LLVM.Core as LLVM
import LLVM.Core (Value, valueOf)

import Type.Data.Num.Decimal (d0, d1)

import Data.Tuple.HT (mapSnd)
import Data.Word (Word)

import Control.Applicative (liftA2, (<$>))

import NumericPrelude.Numeric ()
import NumericPrelude.Base


data T a = Cons (Value Word) a

instance Functor T where
   fmap :: forall a b. (a -> b) -> T a -> T b
fmap a -> b
f (Cons Value Word
len a
y) = Value Word -> b -> T b
forall a. Value Word -> a -> T a
Cons Value Word
len (a -> b
f a
y)

instance (Tuple.Phi a) => Tuple.Phi (T a) where
   phi :: forall r. BasicBlock -> T a -> CodeGenFunction r (T a)
phi BasicBlock
bb (Cons Value Word
len a
y) =
      (Value Word -> a -> T a)
-> CodeGenFunction r (Value Word)
-> CodeGenFunction r a
-> CodeGenFunction r (T a)
forall a b c.
(a -> b -> c)
-> CodeGenFunction r a
-> CodeGenFunction r b
-> CodeGenFunction r c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Value Word -> a -> T a
forall a. Value Word -> a -> T a
Cons (BasicBlock -> Value Word -> CodeGenFunction r (Value Word)
forall a r. Phi a => BasicBlock -> a -> CodeGenFunction r a
forall r.
BasicBlock -> Value Word -> CodeGenFunction r (Value Word)
Tuple.phi BasicBlock
bb Value Word
len) (BasicBlock -> a -> CodeGenFunction r a
forall a r. Phi a => BasicBlock -> a -> CodeGenFunction r a
forall r. BasicBlock -> a -> CodeGenFunction r a
Tuple.phi BasicBlock
bb a
y)
   addPhi :: forall r. BasicBlock -> T a -> T a -> CodeGenFunction r ()
addPhi BasicBlock
bb (Cons Value Word
lenA a
ya) (Cons Value Word
lenB a
yb) =
      BasicBlock -> Value Word -> Value Word -> CodeGenFunction r ()
forall a r. Phi a => BasicBlock -> a -> a -> CodeGenFunction r ()
forall r.
BasicBlock -> Value Word -> Value Word -> CodeGenFunction r ()
Tuple.addPhi BasicBlock
bb Value Word
lenA Value Word
lenB CodeGenFunction r ()
-> CodeGenFunction r () -> CodeGenFunction r ()
forall a b.
CodeGenFunction r a -> CodeGenFunction r b -> CodeGenFunction r b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BasicBlock -> a -> a -> CodeGenFunction r ()
forall a r. Phi a => BasicBlock -> a -> a -> CodeGenFunction r ()
forall r. BasicBlock -> a -> a -> CodeGenFunction r ()
Tuple.addPhi BasicBlock
bb a
ya a
yb

instance (Tuple.Undefined a) => Tuple.Undefined (T a) where
   undef :: T a
undef = Value Word -> a -> T a
forall a. Value Word -> a -> T a
Cons Value Word
forall a. Undefined a => a
Tuple.undef a
forall a. Undefined a => a
Tuple.undef

instance (Tuple.Zero a) => Tuple.Zero (T a) where
   zero :: T a
zero = Value Word -> a -> T a
forall a. Value Word -> a -> T a
Cons Value Word
forall a. Zero a => a
Tuple.zero a
forall a. Zero a => a
Tuple.zero

type Struct a = LLVM.Struct (Word, (a, ()))

parameterMemory ::
   (Memory.C a) =>
   Memory.Record r (Struct (Memory.Struct a)) (T a)
parameterMemory :: forall a r. C a => Record r (Struct (Struct a)) (T a)
parameterMemory =
   (Value Word -> a -> T a)
-> Element r (Struct (Struct a)) (T a) (Value Word)
-> Element r (Struct (Struct a)) (T a) a
-> Element r (Struct (Struct a)) (T a) (T a)
forall a b c.
(a -> b -> c)
-> Element r (Struct (Struct a)) (T a) a
-> Element r (Struct (Struct a)) (T a) b
-> Element r (Struct (Struct a)) (T a) c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Value Word -> a -> T a
forall a. Value Word -> a -> T a
Cons
      ((T a -> Value Word)
-> Proxy D0 -> Element r (Struct (Struct a)) (T a) (Value Word)
forall x o n v r.
(C x, GetValue o n, ValueType o n ~ Struct x,
 GetElementPtr o (n, ()), ElementPtrType o (n, ()) ~ Struct x) =>
(v -> x) -> n -> Element r o v x
Memory.element (\(Cons Value Word
len a
_y) -> Value Word
len) Proxy D0
d0)
      ((T a -> a) -> Proxy D1 -> Element r (Struct (Struct a)) (T a) a
forall x o n v r.
(C x, GetValue o n, ValueType o n ~ Struct x,
 GetElementPtr o (n, ()), ElementPtrType o (n, ()) ~ Struct x) =>
(v -> x) -> n -> Element r o v x
Memory.element (\(Cons Value Word
_len a
y) -> a
y)   Proxy D1
d1)

instance (Memory.C a) => Memory.C (T a) where
   type Struct (T a) = Struct (Memory.Struct a)
   load :: forall r. Value (Ptr (Struct (T a))) -> CodeGenFunction r (T a)
load = Record r (Struct (Struct a)) (T a)
-> Value (Ptr (Struct (Struct a))) -> CodeGenFunction r (T a)
forall r o llvmValue.
Record r o llvmValue
-> Value (Ptr o) -> CodeGenFunction r llvmValue
Memory.loadRecord Record r (Struct (Struct a)) (T a)
forall a r. C a => Record r (Struct (Struct a)) (T a)
parameterMemory
   store :: forall r. T a -> Value (Ptr (Struct (T a))) -> CodeGenFunction r ()
store = Record r (Struct (Struct a)) (T a)
-> T a -> Value (Ptr (Struct (Struct a))) -> CodeGenFunction r ()
forall r o llvmValue.
Record r o llvmValue
-> llvmValue -> Value (Ptr o) -> CodeGenFunction r ()
Memory.storeRecord Record r (Struct (Struct a)) (T a)
forall a r. C a => Record r (Struct (Struct a)) (T a)
parameterMemory
   decompose :: forall r. Value (Struct (T a)) -> CodeGenFunction r (T a)
decompose = Record r (Struct (Struct a)) (T a)
-> Value (Struct (Struct a)) -> CodeGenFunction r (T a)
forall r o llvmValue.
Record r o llvmValue -> Value o -> CodeGenFunction r llvmValue
Memory.decomposeRecord Record r (Struct (Struct a)) (T a)
forall a r. C a => Record r (Struct (Struct a)) (T a)
parameterMemory
   compose :: forall r. T a -> CodeGenFunction r (Value (Struct (T a)))
compose = Record r (Struct (Struct a)) (T a)
-> T a -> CodeGenFunction r (Value (Struct (Struct a)))
forall o r llvmValue.
IsType o =>
Record r o llvmValue -> llvmValue -> CodeGenFunction r (Value o)
Memory.composeRecord Record r (Struct (Struct a)) (T a)
forall a r. C a => Record r (Struct (Struct a)) (T a)
parameterMemory


causalMap ::
   (Expr.Aggregate a am, Expr.Aggregate b bm) =>
   (a -> b) -> Causal.T (T am) (T bm)
causalMap :: forall a am b bm.
(Aggregate a am, Aggregate b bm) =>
(a -> b) -> T (T am) (T bm)
causalMap a -> b
f = (forall r. T am -> CodeGenFunction r (T bm)) -> T (T am) (T bm)
forall a b. (forall r. a -> CodeGenFunction r b) -> T a b
Causal.map (\(Cons Value Word
len am
y) -> Value Word -> bm -> T bm
forall a. Value Word -> a -> T a
Cons Value Word
len (bm -> T bm) -> CodeGenFunction r bm -> CodeGenFunction r (T bm)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> b) -> am -> CodeGenFunction r bm
forall ae am be bm r.
(Aggregate ae am, Aggregate be bm) =>
(ae -> be) -> am -> CodeGenFunction r bm
Expr.unliftM1 a -> b
f am
y)


flatten :: (Memory.C a) => Sig.T (T a) -> Sig.T a
flatten :: forall a. C a => T (T a) -> T a
flatten (Sig.Cons forall r c.
Phi c =>
global -> Value (Ptr local) -> state -> T r c (T a, state)
next forall r. CodeGenFunction r (global, state)
start forall r. global -> CodeGenFunction r ()
stop) =
   (forall r c.
 Phi c =>
 global
 -> Value (Ptr local) -> (T a, state) -> T r c (a, (T a, state)))
-> (forall r. CodeGenFunction r (global, (T a, state)))
-> (forall r. global -> CodeGenFunction r ())
-> T a
forall a global local state.
(C global, IsSized local, C state) =>
(forall r c.
 Phi c =>
 global -> Value (Ptr local) -> state -> T r c (a, state))
-> (forall r. CodeGenFunction r (global, state))
-> (forall r. global -> CodeGenFunction r ())
-> T a
Sig.Cons
      (\global
global Value (Ptr local)
local (T a, state)
state0 -> do
         ~(Cons Value Word
length1 a
y1, state
s1) <-
            CodeGenFunction r (Value Bool, (T a, state)) -> T r c (T a, state)
forall z r a. Phi z => CodeGenFunction r (Value Bool, a) -> T r z a
Maybe.fromBool (CodeGenFunction r (Value Bool, (T a, state))
 -> T r c (T a, state))
-> CodeGenFunction r (Value Bool, (T a, state))
-> T r c (T a, state)
forall a b. (a -> b) -> a -> b
$
            (Value Bool, (T a, state))
-> ((Value Bool, (T a, state)) -> CodeGenFunction r (Value Bool))
-> ((Value Bool, (T a, state))
    -> CodeGenFunction r (Value Bool, (T a, state)))
-> CodeGenFunction r (Value Bool, (T a, state))
forall a r.
Phi a =>
a
-> (a -> CodeGenFunction r (Value Bool))
-> (a -> CodeGenFunction r a)
-> CodeGenFunction r a
whileLoop (Bool -> Value Bool
forall a. IsConst a => a -> Value a
valueOf Bool
True, (T a, state)
state0)
               (\(Value Bool
cont, (Cons Value Word
len a
_y, state
_s)) ->
                  Value Bool
-> Value Bool -> CodeGenFunction r (BinOpValue Value Value Bool)
forall (value0 :: * -> *) (value1 :: * -> *) a r.
(ValueCons2 value0 value1, IsInteger a) =>
value0 a
-> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)
LLVM.and Value Bool
cont (Value Bool -> CodeGenFunction r (Value Bool))
-> CodeGenFunction r (Value Bool) -> CodeGenFunction r (Value Bool)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CmpPredicate
-> Value Word
-> Value Word
-> CodeGenFunction r (CmpResult (Value Word))
forall r.
CmpPredicate
-> Value Word
-> Value Word
-> CodeGenFunction r (CmpResult (Value Word))
forall a r.
Comparison a =>
CmpPredicate -> a -> a -> CodeGenFunction r (CmpResult a)
A.cmp CmpPredicate
LLVM.CmpEQ Value Word
len Value Word
forall a. Additive a => a
A.zero)
               (\(Value Bool
_cont, (Cons Value Word
_len a
_y, state
s)) ->
                  T r (Value Bool, (T a, state)) (T a, state)
-> CodeGenFunction r (Value Bool, (T a, state))
forall a r.
Undefined a =>
T r (Value Bool, a) a -> CodeGenFunction r (Value Bool, a)
Maybe.toBool (T r (Value Bool, (T a, state)) (T a, state)
 -> CodeGenFunction r (Value Bool, (T a, state)))
-> T r (Value Bool, (T a, state)) (T a, state)
-> CodeGenFunction r (Value Bool, (T a, state))
forall a b. (a -> b) -> a -> b
$ global
-> Value (Ptr local)
-> state
-> T r (Value Bool, (T a, state)) (T a, state)
forall r c.
Phi c =>
global -> Value (Ptr local) -> state -> T r c (T a, state)
next global
global Value (Ptr local)
local state
s)
         Value Word
length2 <- CodeGenFunction r (Value Word) -> T r c (Value Word)
forall r a z. CodeGenFunction r a -> T r z a
Maybe.lift (Value Word -> CodeGenFunction r (Value Word)
forall a r.
(IsArithmetic a, IsConst a, Num a) =>
Value a -> CodeGenFunction r (Value a)
A.dec Value Word
length1)
         (a, (T a, state)) -> T r c (a, (T a, state))
forall a. a -> T r c a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
y1, (Value Word -> a -> T a
forall a. Value Word -> a -> T a
Cons Value Word
length2 a
y1, state
s1)))
      ((state -> (T a, state))
-> (global, state) -> (global, (T a, state))
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd ((,) (Value Word -> a -> T a
forall a. Value Word -> a -> T a
Cons Value Word
forall a. Additive a => a
A.zero a
forall a. Undefined a => a
Tuple.undef)) ((global, state) -> (global, (T a, state)))
-> CodeGenFunction r (global, state)
-> CodeGenFunction r (global, (T a, state))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CodeGenFunction r (global, state)
forall r. CodeGenFunction r (global, state)
start)
      global -> CodeGenFunction r ()
forall r. global -> CodeGenFunction r ()
stop