Complex.hs

{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Synthesizer.LLVM.Complex (
   Complex.T(Complex.real, Complex.imag),
   Struct,
   (+:),
   Complex.cis,
   Complex.scale,
   constOf, unfold,
   ) where

import qualified Synthesizer.LLVM.Value as Value

import qualified LLVM.Extra.Nice.Value.Marshal as Marshal
import qualified LLVM.Extra.Nice.Value as NiceValue
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Tuple as Tuple

import qualified LLVM.Core as LLVM
import LLVM.Core (Value, ConstValue, IsConst)

import qualified Type.Data.Num.Decimal as TypeNum

import Control.Applicative (liftA2)

import qualified Number.Complex as Complex
import Number.Complex ((+:))


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

constOf :: IsConst a =>
   Complex.T a -> ConstValue (Struct a)
constOf x =
   LLVM.constStruct
      (LLVM.constOf $ Complex.real x,
        (LLVM.constOf $ Complex.imag x,
          ()))

unfold ::
   Value (Struct a) -> Complex.T (Value.T (Value a))
unfold x =
   Value.lift0 (LLVM.extractvalue x TypeNum.d0)
   +:
   Value.lift0 (LLVM.extractvalue x TypeNum.d1)


instance (Tuple.Undefined a) => Tuple.Undefined (Complex.T a) where
   undef = Tuple.undef +: Tuple.undef

instance (Tuple.Phi a) => Tuple.Phi (Complex.T a) where
   phi bb v =
      liftA2 (+:)
         (Tuple.phi bb (Complex.real v))
         (Tuple.phi bb (Complex.imag v))
   addPhi bb x y = do
      Tuple.addPhi bb (Complex.real x) (Complex.real y)
      Tuple.addPhi bb (Complex.imag x) (Complex.imag y)


memory ::
   (Memory.C l) =>
   Memory.Record r (Struct (Memory.Struct l)) (Complex.T l)
memory =
   liftA2 (+:)
      (Memory.element Complex.real TypeNum.d0)
      (Memory.element Complex.imag TypeNum.d1)

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



instance (NiceValue.C a) => NiceValue.C (Complex.T a) where
   type Repr (Complex.T a) = Complex.T (NiceValue.Repr a)
   cons x =
      consNice
         (NiceValue.cons $ Complex.real x)
         (NiceValue.cons $ Complex.imag x)
   undef = consNice NiceValue.undef NiceValue.undef
   zero = consNice NiceValue.zero NiceValue.zero
   phi bb a =
      case deconsNice a of
         (a0,a1) -> liftA2 consNice (NiceValue.phi bb a0) (NiceValue.phi bb a1)
   addPhi bb a b =
      case (deconsNice a, deconsNice b) of
         ((a0,a1), (b0,b1)) ->
            NiceValue.addPhi bb a0 b0 >> NiceValue.addPhi bb a1 b1

consNice :: NiceValue.T a -> NiceValue.T a -> NiceValue.T (Complex.T a)
consNice (NiceValue.Cons a) (NiceValue.Cons b) = NiceValue.Cons (a+:b)

deconsNice :: NiceValue.T (Complex.T a) -> (NiceValue.T a, NiceValue.T a)
deconsNice (NiceValue.Cons x) =
   (NiceValue.Cons $ Complex.real x, NiceValue.Cons $ Complex.imag x)


instance (Marshal.C a) => Marshal.C (Complex.T a) where
   pack x =
      LLVM.consStruct
         (Marshal.pack $ Complex.real x)
         (Marshal.pack $ Complex.imag x)
   unpack = LLVM.uncurryStruct $ \a b -> Marshal.unpack a +: Marshal.unpack b