{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
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 f (Cons len y) = Cons len (f y)
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
causalMap ::
(Expr.Aggregate a am, Expr.Aggregate b bm) =>
(a -> b) -> Causal.T (T am) (T bm)
causalMap f = Causal.map (\(Cons len y) -> Cons len <$> Expr.unliftM1 f y)
flatten :: (Memory.C a) => Sig.T (T a) -> Sig.T a
flatten (Sig.Cons next start stop) =
Sig.Cons
(\global local 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 global local s)
length2 <- Maybe.lift (A.dec length1)
return (y1, (Cons length2 y1, s1)))
(mapSnd ((,) (Cons A.zero Tuple.undef)) <$> start)
stop