module Ivory.Language.MemArea where
import Prelude ()
import Prelude.Compat
import Ivory.Language.Area
import Ivory.Language.Init
import Ivory.Language.Proxy
import Ivory.Language.Ref
import Ivory.Language.Scope
import Ivory.Language.Type
import qualified Ivory.Language.Syntax as I
import qualified MonadLib as M
import qualified MonadLib.Derive as M
newtype AreaInitM a = AreaInitM
{ unAreaInitM :: M.ReaderT String (M.StateT Int M.Id) a }
areaInit_iso :: M.Iso (M.ReaderT String (M.StateT Int M.Id)) AreaInitM
areaInit_iso = M.Iso AreaInitM unAreaInitM
instance Functor AreaInitM where
fmap = M.derive_fmap areaInit_iso
instance Applicative AreaInitM where
pure = M.derive_pure areaInit_iso
(<*>) = M.derive_apply areaInit_iso
instance Monad AreaInitM where
return = pure
(>>=) = M.derive_bind areaInit_iso
instance M.ReaderM AreaInitM String where
ask = M.derive_ask areaInit_iso
instance M.StateM AreaInitM Int where
get = M.derive_get areaInit_iso
set = M.derive_set areaInit_iso
instance FreshName AreaInitM where
freshName s = do
i <- M.get
M.set $! i + 1
name <- M.ask
return (I.VarLitName ("_iv_" ++ name ++ "_" ++ s ++ show i))
runAreaInitM :: String -> AreaInitM a -> a
runAreaInitM s x = fst (M.runId (M.runStateT 0 (M.runReaderT s(unAreaInitM x))))
areaInit :: String -> Init area -> (I.Init, [Binding])
areaInit s ini = runAreaInitM s (runInit (getInit ini))
data MemArea (area :: Area *)
= MemImport I.AreaImport
| MemArea I.Area [I.Area]
deriving (Eq, Show)
memSym :: MemArea area -> I.Sym
memSym m = case m of
MemImport i -> I.aiSym i
MemArea a _ -> I.areaSym a
bindingArea :: Bool -> Binding -> I.Area
bindingArea isConst b = I.Area
{ I.areaSym = bindingSym b
, I.areaConst = isConst
, I.areaType = bindingType b
, I.areaInit = bindingInit b
}
makeArea :: I.Sym -> Bool -> I.Type -> I.Init -> I.Area
makeArea sym isConst ty ini = I.Area
{ I.areaSym = sym
, I.areaConst = isConst
, I.areaType = ty
, I.areaInit = ini
}
area :: forall area. (IvoryArea area, IvoryZero area)
=> I.Sym -> Maybe (Init area) -> MemArea area
area sym (Just ini) = MemArea a1 as
where
(ini', binds) = areaInit sym ini
ty = ivoryArea (Proxy :: Proxy area)
a1 = makeArea sym False ty ini'
as = map (bindingArea False) binds
area sym Nothing = MemArea a1 []
where
ty = ivoryArea (Proxy :: Proxy area)
a1 = makeArea sym False ty I.zeroInit
importArea :: IvoryArea area => I.Sym -> String -> MemArea area
importArea name header = MemImport I.AreaImport
{ I.aiSym = name
, I.aiConst = False
, I.aiFile = header
}
newtype ConstMemArea (area :: Area *) = ConstMemArea (MemArea area)
constArea :: forall area. IvoryArea area
=> I.Sym -> Init area -> ConstMemArea area
constArea sym ini = ConstMemArea $ MemArea a1 as
where
(ini', binds) = areaInit sym ini
ty = ivoryArea (Proxy :: Proxy area)
a1 = makeArea sym True ty ini'
as = map (bindingArea True) binds
importConstArea :: IvoryArea area => I.Sym -> String -> ConstMemArea area
importConstArea name header = ConstMemArea $ MemImport I.AreaImport
{ I.aiSym = name
, I.aiConst = False
, I.aiFile = header
}
class IvoryAddrOf (mem :: Area * -> *) ref | mem -> ref, ref -> mem where
addrOf :: IvoryArea area => mem area -> ref 'Global area
primAddrOf :: IvoryArea area => MemArea area -> I.Expr
primAddrOf mem = I.ExpAddrOfGlobal (memSym mem)
instance IvoryAddrOf MemArea Ref where
addrOf mem = wrapExpr (primAddrOf mem)
instance IvoryAddrOf ConstMemArea ConstRef where
addrOf (ConstMemArea mem) = wrapExpr (primAddrOf mem)