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 (
   T(..),
   Struct,
   parameterMemory,
   flatten,
   piecewiseConstant,
   lazySize,
   ) where

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

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.DSL.Parameter as Param

import qualified LLVM.Extra.MaybeContinuation as Maybe
import qualified LLVM.Extra.Marshal as Marshal
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.Word (Word)

import Control.Applicative (liftA2)

import NumericPrelude.Numeric ()
import NumericPrelude.Base


data T a = Cons (Value Word) a

instance (Tuple.Phi a) => Tuple.Phi (T a) where
   phi bb (Cons len y) =
      liftA2 Cons (Tuple.phi bb len) (Tuple.phi bb y)
   addPhi bb (Cons lenA ya) (Cons lenB yb) =
      Tuple.addPhi bb lenA lenB >> Tuple.addPhi bb ya yb

instance (Tuple.Undefined a) => Tuple.Undefined (T a) where
   undef = Cons Tuple.undef Tuple.undef

instance (Tuple.Zero a) => Tuple.Zero (T a) where
   zero = Cons Tuple.zero Tuple.zero

type Struct a = LLVM.Struct (Word, (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 Tuple.undef)) . start)
      (stop . snd))


piecewiseConstant ::
   (Marshal.C a, Tuple.ValueOf a ~ value, Marshal.Struct a ~ struct) =>
   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