ConstantPiece.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{- |
Data type that allows handling of piecewise constant signals
independently from the source.
-}
module Synthesizer.LLVM.ConstantPiece where

import qualified Synthesizer.LLVM.Parameterized.SignalPrivate as SigP
import qualified Synthesizer.LLVM.Simple.SignalPrivate as Sig
import qualified Synthesizer.LLVM.Parameter as Param

import qualified Synthesizer.LLVM.Storable.LazySizeIterator as SizeIt
import qualified Data.StorableVector.Lazy.Pattern as SVP

import qualified Synthesizer.LLVM.EventIterator as EventIt
import qualified Data.EventList.Relative.BodyTime as EventList
import qualified Numeric.NonNegative.Wrapper as NonNeg

import qualified LLVM.Extra.MaybeContinuation as Maybe
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Class as Class
import qualified LLVM.Extra.Arithmetic as A
import LLVM.Extra.Control (whileLoop, )
import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, )

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

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

import Data.Word (Word32, )
import Foreign.Storable.Tuple ()
import Foreign.Storable (Storable, )

import Control.Applicative (liftA2, )

import NumericPrelude.Numeric ()
import NumericPrelude.Base


data T a = Cons (Value Word32) a

instance (Phi a) => Phi (T a) where
   phis bb (Cons len y) =
      liftA2 Cons (phis bb len) (phis bb y)
   addPhis bb (Cons lenA ya) (Cons lenB yb) =
      addPhis bb lenA lenB >> addPhis bb ya yb

instance (Undefined a) => Undefined (T a) where
   undefTuple = Cons Class.undefTuple Class.undefTuple

instance (Class.Zero a) => Class.Zero (T a) where
   zeroTuple = Cons Class.zeroTuple Class.zeroTuple

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

parameterMemory ::
   (Memory.C a) =>
   Memory.Record r (Struct (Memory.Struct a)) (T a)
parameterMemory =
   liftA2 Cons
      (Memory.element (\(Cons len _y) -> len) d0)
      (Memory.element (\(Cons _len y) -> y)   d1)

instance (Memory.C a) => Memory.C (T a) where
   type Struct (T a) = Struct (Memory.Struct a)
   load = Memory.loadRecord parameterMemory
   store = Memory.storeRecord parameterMemory
   decompose = Memory.decomposeRecord parameterMemory
   compose = Memory.composeRecord parameterMemory


flatten ::
   (Sig.C signal, Memory.C value) =>
   signal (T value) ->
   signal value
flatten = Sig.alter (\(Sig.Core next start stop) ->
   Sig.Core
      (\context state0 -> do
         ~(Cons length1 y1, s1) <-
            Maybe.fromBool $
            whileLoop (valueOf True, state0)
               (\(cont, (Cons len _y, _s)) ->
                  LLVM.and cont =<< A.cmp LLVM.CmpEQ len A.zero)
               (\(_cont, (Cons _len _y, s)) ->
                  Maybe.toBool $ next context s)
         length2 <- Maybe.lift (A.dec length1)
         return (y1, (Cons length2 y1, s1)))
      (fmap ((,) (Cons A.zero undefTuple)) . start)
      (stop . snd))


piecewiseConstant ::
   (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>
   Param.T p (EventList.T NonNeg.Int a) ->
   SigP.T p (T value)
piecewiseConstant evs = SigP.Cons
   (\stable yPtr () -> do
      len <- Maybe.lift $ do
         nextFn <-
            LLVM.staticNamedFunction
               "ConstantPiece.piecewiseConstant.nextChunk"
               EventIt.nextCallBack
         LLVM.call nextFn stable yPtr
      Maybe.guard =<<
         Maybe.lift (A.cmp LLVM.CmpNE len A.zero)
      y <- Maybe.lift $ Memory.load yPtr
      return (Cons len y, ()))
   LLVM.alloca
   return
   (const $ const $ return ())
   (\p -> do
      stable <- EventIt.new (Param.get evs p)
      return (stable, (stable, ())))
   EventIt.dispose


lazySize ::
   Param.T p SVP.LazySize ->
   SigP.T p (T ())
lazySize size = SigP.Cons
   (\stable () () -> do
      len <- Maybe.lift $ do
         nextFn <-
            LLVM.staticNamedFunction
               "ConstantPiece.lazySize.nextChunk"
               SizeIt.nextCallBack
         LLVM.call nextFn stable
      Maybe.guard =<<
         Maybe.lift (A.cmp LLVM.CmpNE len A.zero)
      return (Cons len (), ()))
   (return ())
   return
   (const $ const $ return ())
   (\p -> do
      stable <- SizeIt.new (Param.get size p)
      return (stable, (stable, ())))
   SizeIt.dispose