module Ivory.Language.Init where
import Ivory.Language.Area
import Ivory.Language.Array
import Ivory.Language.Float
import Ivory.Language.IBool
import Ivory.Language.IChar
import Ivory.Language.Monad
import Ivory.Language.Proc
import Ivory.Language.Proxy
import Ivory.Language.Ptr
import Ivory.Language.Ref
import Ivory.Language.Scope
import Ivory.Language.Struct
import Ivory.Language.Sint
import Ivory.Language.Type
import Ivory.Language.Uint
import qualified Ivory.Language.Syntax as I
import qualified Ivory.Language.Effects as E
import Control.Monad (forM_)
import Data.Monoid (Monoid(..),mconcat)
import GHC.TypeLits
data XInit
= IVal I.Type I.Init
| IArray I.Type [XInit]
| IStruct I.Type [(String, XInit)]
| IFresh I.Type XInit (I.Var -> I.Init)
initType :: XInit -> I.Type
initType (IVal ty _) = ty
initType (IArray ty _) = ty
initType (IStruct ty _) = ty
initType (IFresh ty _ _) = ty
newtype Init (area :: Area *) = Init { getInit :: XInit }
class IvoryZero (area :: Area *) where
izero :: Init area
class Monad m => FreshName m where
freshName :: String -> m I.Var
instance FreshName (Ivory eff) where
freshName = freshVar
data Binding = Binding
{ bindingVar :: I.Var
, bindingType :: I.Type
, bindingInit :: I.Init
} deriving Show
bindingSym :: Binding -> I.Sym
bindingSym b =
case bindingVar b of
I.VarName s -> s
I.VarInternal s -> s
I.VarLitName s -> s
runInit :: FreshName m => XInit -> m (I.Init, [Binding])
runInit ini =
case ini of
IVal _ i ->
return (i, [])
IArray _ is -> do
binds <- mapM runInit is
let inis = map fst binds
let aux = concatMap snd binds
return (I.InitArray inis, aux)
IStruct _ is -> do
binds <- mapM iniStruct is
let inis = map fst binds
let aux = concatMap snd binds
return (I.InitStruct inis, aux)
IFresh _ i f -> do
var <- freshName "init"
(i', aux) <- runInit i
let ty = initType i
let aux' = aux ++ [Binding var ty i']
return (f var, aux')
where
iniStruct (s, i) = do
(i', binds) <- runInit i
return ((s, i'), binds)
class IvoryVar e => IvoryInit e where
ival :: e -> Init (Stored e)
ival e = Init (IVal ty (I.InitExpr ty (unwrapExpr e)))
where
ty = ivoryType (Proxy :: Proxy e)
instance IvoryInit IBool
instance IvoryInit IChar
instance IvoryInit Uint8
instance IvoryInit Uint16
instance IvoryInit Uint32
instance IvoryInit Uint64
instance IvoryInit Sint8
instance IvoryInit Sint16
instance IvoryInit Sint32
instance IvoryInit Sint64
instance IvoryInit IFloat
instance IvoryInit IDouble
instance ProcType proc => IvoryInit (ProcPtr proc)
instance IvoryArea area => IvoryInit (Ptr Global area)
instance SingI len => IvoryInit (Ix len)
instance IvoryZero (Stored IBool) where
izero = ival false
instance IvoryZero (Stored IChar) where
izero = ival (char '\0')
instance IvoryArea area => IvoryZero (Stored (Ptr Global area)) where
izero = ival nullPtr
instance (Num a, IvoryInit a) => IvoryZero (Stored a) where
izero = ival 0
instance (IvoryZero area, IvoryArea area, SingI len) =>
IvoryZero (Array len area) where
izero = Init (IVal ty I.InitZero)
where
ty = ivoryArea (Proxy :: Proxy (Array len area))
iarray :: forall len area. (IvoryArea area, SingI len)
=> [Init area] -> Init (Array len area)
iarray is = Init (IArray ty (take len (map getInit is)))
where
len = fromInteger (fromTypeNat (sing :: Sing len))
ty = ivoryArea (Proxy :: Proxy (Array len area))
instance IvoryStruct sym => IvoryZero (Struct sym) where
izero = Init (IVal ty I.InitZero)
where
ty = ivoryArea (Proxy :: Proxy (Struct sym))
newtype InitStruct (sym :: Symbol) = InitStruct
{ getInitStruct :: [(String, XInit)]
}
instance IvoryStruct sym => Monoid (InitStruct sym) where
mempty = InitStruct []
mappend l r = InitStruct (mappend (getInitStruct l) (getInitStruct r))
istruct :: forall sym. IvoryStruct sym => [InitStruct sym] -> Init (Struct sym)
istruct is = Init (IStruct ty fields)
where
fields = [ (l,i) | (l,i) <- getInitStruct (mconcat is) ]
ty = ivoryArea (Proxy :: Proxy (Struct sym))
(.=) :: Label sym area -> Init area -> InitStruct sym
l .= ini = InitStruct [(getLabel l, getInit ini)]
local :: forall eff s area. (IvoryArea area, E.GetAlloc eff ~ E.Scope s)
=> Init area
-> Ivory eff (Ref (Stack s) area)
local ini = do
(i, binds) <- runInit (getInit ini)
forM_ binds $ \b -> do
emit (I.Local (bindingType b) (bindingVar b) (bindingInit b))
lname <- freshVar "local"
let ty = ivoryArea (Proxy :: Proxy area)
emit (I.Local ty lname i)
rname <- freshVar "ref"
let areaTy = ivoryArea (Proxy :: Proxy area)
emit (I.AllocRef areaTy rname (I.NameVar lname))
return (wrapExpr (I.ExpVar rname))