module E.Values where
import Control.Monad.Identity
import Data.Monoid
import Data.List
import Data.Ratio
import C.Prims
import E.E
import E.FreeVars()
import E.Subst
import E.TypeCheck
import Info.Info(HasInfo(..))
import Info.Types
import Name.Id
import Name.Name
import Name.Names
import Name.VConsts
import Support.CanType
import Support.FreeVars
import Support.Tuple
import Util.SetLike
import qualified Info.Info as Info
instance Tuple E where
tupleNil = vUnit
tupleMany es = ELit litCons { litName = nameTuple DataConstructor (length es), litArgs = es, litType = ltTuple ts } where
ts = map getType es
eTuple :: [E] -> E
eTuple = tuple
eTuple' es = ELit $ unboxedTuple es
unboxedTuple es = litCons { litName = unboxedNameTuple DataConstructor (length es), litArgs = es, litType = ltTuple' ts } where
ts = map getType es
unboxedUnit :: E
unboxedUnit = ELit $ unboxedTuple []
unboxedTyUnit :: E
unboxedTyUnit = ltTuple' []
class ToE a where
toE :: a -> E
typeE :: a -> E
class ToEzh a where
toEzh :: a -> E
typeEzh :: a -> E
instance ToEzh Char where
toEzh ch = ELit $ LitInt (fromIntegral $ fromEnum ch) tCharzh
typeEzh _ = tCharzh
instance ToEzh Int where
toEzh ch = ELit $ LitInt (fromIntegral ch) tIntzh
typeEzh _ = tIntzh
instance ToEzh Integer where
toEzh ch = ELit $ LitInt (fromIntegral ch) tIntegerzh
typeEzh _ = tIntegerzh
instance ToE () where
toE () = vUnit
typeE _ = tUnit
instance ToE Bool where
toE True = vTrue
toE False = vFalse
typeE _ = tBool
instance ToE Char where
toE ch = ELit (litCons { litName = dc_Char, litArgs = [toEzh ch], litType = tChar })
typeE _ = tChar
instance ToE Rational where
toE rat = ELit (litCons { litName = dc_Ratio, litArgs = [toE (numerator rat), toE (denominator rat)], litType = tRational })
typeE _ = tRational
instance ToE Integer where
toE ch = ELit (litCons { litName = dc_Integer, litArgs = [toEzh ch], litType = tInteger })
typeE _ = tInteger
instance ToE Int where
toE ch = ELit (litCons { litName = dc_Int, litArgs = [toEzh ch], litType = tInt })
typeE _ = tInt
instance ToE a => ToE [a] where
toE xs@[] = eNil (typeE xs)
toE (x:xs) = eCons (toE x) (toE xs)
typeE (_::[a]) = ELit (litCons { litName = tc_List, litArgs = [typeE (undefined::a)], litType = eStar })
eCons x xs = ELit $ litCons { litName = dc_Cons, litArgs = [x,xs], litType = getType xs }
eNil t = ELit $ litCons { litName = dc_EmptyList, litArgs = [], litType = t }
emptyCase = ECase {
eCaseAllFV = mempty,
eCaseDefault = Nothing,
eCaseAlts = [],
eCaseBind = error "emptyCase: bind",
eCaseType = error "emptyCase: type",
eCaseScrutinee = error "emptyCase: scrutinee"
}
eCaseTup e vs w = caseUpdate emptyCase { eCaseScrutinee = e, eCaseBind = (tVr emptyId (getType e)), eCaseType = getType w, eCaseAlts = [Alt litCons { litName = nameTuple DataConstructor (length vs), litArgs = vs, litType = getType e } w] }
eCaseTup' e vs w = caseUpdate emptyCase { eCaseScrutinee = e, eCaseBind = (tVr emptyId (getType e)), eCaseType = getType w, eCaseAlts = [Alt litCons { litName = unboxedNameTuple DataConstructor (length vs), litArgs = vs, litType = getType e} w] }
eJustIO w x = eTuple' [w,x]
eCase e alts@(alt:_) Unknown = caseUpdate emptyCase { eCaseScrutinee = e, eCaseBind = (tVr emptyId (getType e)), eCaseType = getType alt, eCaseAlts = alts }
eCase e alts els = caseUpdate emptyCase { eCaseScrutinee = e, eCaseBind = (tVr emptyId (getType e)), eCaseDefault = Just els, eCaseAlts = alts, eCaseType = getType els }
eLet :: TVr -> E -> E -> E
eLet TVr { tvrIdent = eid } _ e' | eid == emptyId = e'
eLet t@(TVr { tvrType = ty}) e e'
| sortKindLike ty && isAtomic e = subst t e e'
| sortKindLike ty = ELetRec [(t,e)] (typeSubst mempty (msingleton (tvrIdent t) e) e')
| isUnboxed ty && isAtomic e = subst t e e'
| isUnboxed ty = eStrictLet t e e'
eLet t e e' = ELetRec [(t,e)] e'
eStrictLet t@(TVr { tvrType = ty }) v e | sortKindLike ty = eLet t v e
eStrictLet t v e = caseUpdate emptyCase { eCaseScrutinee = v, eCaseBind = t, eCaseDefault = Just e, eCaseType = getType e }
substLet :: [(TVr,E)] -> E -> E
substLet ds e = ans where
(as,nas) = partition (isAtomic . snd) (filter ((/= emptyId) . tvrIdent . fst) ds)
tas = filter (sortKindLike . tvrType . fst) nas
ans = eLetRec (as ++ nas) (typeSubst' (fromList [ (n,e) | (TVr { tvrIdent = n },e) <- as]) (fromList [ (n,e) | (TVr { tvrIdent = n },e) <- tas]) e)
substLet' :: [(TVr,E)] -> E -> E
substLet' ds' e = ans where
(hh,ds) = partition (isUnboxed . tvrType . fst) ds'
nas = filter ((/= emptyId) . tvrIdent . fst) ds
tas = filter (sortKindLike . tvrType . fst) nas
ans = case (nas,tas) of
([],_) -> hhh hh $ e
(nas,[]) -> hhh hh $ ELetRec nas e
_ -> let
f = typeSubst' mempty (fromList [ (n,e) | (TVr { tvrIdent = n },e) <- tas])
nas' = [ (v,f e) | (v,e) <- nas]
in hhh hh $ ELetRec nas' (f e)
hhh [] e = e
hhh ((h,v):hh) e = eLet h v (hhh hh e)
eLetRec = substLet'
prim_seq a b | isWHNF a = b
prim_seq a b = caseUpdate emptyCase { eCaseScrutinee = a, eCaseBind = (tVr emptyId (getType a)), eCaseDefault = Just b, eCaseType = getType b }
prim_unsafeCoerce e t = p e' where
(_,e',p) = unsafeCoerceOpt $ EPrim p_unsafeCoerce [e] t
from_unsafeCoerce (EPrim pp [e] t) | pp == p_unsafeCoerce = return (e,t)
from_unsafeCoerce _ = fail "Not unsafeCoerce primitive"
isState_ e = case e of
ELit (LitCons { litName = name }) | name == tc_State_ -> True
_ -> False
unsafeCoerceOpt (EPrim uc [e] t) | uc == p_unsafeCoerce = f (0::Int) e t where
f n e t | Just (e',_) <- from_unsafeCoerce e = f (n + 1) e' t
f n (ELetRec ds e) t = (n + 1, ELetRec ds (p e'),id) where
(n,e',p) = f n e t
f n (EError err _) t = (n,EError err t,id)
f n (ELit (LitInt x _)) t = (n,ELit (LitInt x t),id)
f n (ELit lc@LitCons {}) t = (n,ELit lc { litType = t },id)
f n ec@ECase {} t = (n,caseUpdate nx { eCaseType = t },id) where
Identity nx = caseBodiesMapM (return . flip prim_unsafeCoerce t) ec
f n e t | getType e == t = (n,e,id)
f n e t = (n,e,\z -> EPrim p_unsafeCoerce [z] t)
unsafeCoerceOpt e = (0,e,id)
instance HasInfo TVr where
getInfo = tvrInfo
modifyInfo = tvrInfo_u
isFullyConst :: E -> Bool
isFullyConst (ELit LitCons { litArgs = [] }) = True
isFullyConst (ELit LitCons { litArgs = xs }) = all isFullyConst xs
isFullyConst ELit {} = True
isFullyConst (EPi (TVr { tvrType = t }) x) = isFullyConst t && isFullyConst x
isFullyConst (EPrim p as _) = primIsConstant p && all isFullyConst as
isFullyConst _ = False
isAtomic :: E -> Bool
isAtomic EVar {} = True
isAtomic e | sortTypeLike e = True
isAtomic (EPrim don [x,y] _) | don == p_dependingOn = isAtomic x
isAtomic e = isFullyConst e
isManifestAtomic :: E -> Bool
isManifestAtomic EVar {} = True
isManifestAtomic (ELit LitInt {}) = True
isManifestAtomic (ELit LitCons { litArgs = []}) = True
isManifestAtomic _ = False
isSmall e | isAtomic e = True
isSmall ELit {} = True
isSmall EPrim {} = True
isSmall EError {} = True
isSmall e | (EVar _,xs) <- fromAp e = length xs <= 4
isSmall _ = False
isCheap :: E -> Bool
isCheap EError {} = True
isCheap ELit {} = True
isCheap EPi {} = True
isCheap ELam {} = True
isCheap x | isAtomic x = True
isCheap (EPrim p _ _) = primIsCheap p
isCheap ec@ECase {} = isCheap (eCaseScrutinee ec) && all isCheap (caseBodies ec)
isCheap e | (EVar v,xs) <- fromAp e, Just (Arity n b) <- Info.lookup (tvrInfo v) =
(length xs < n)
|| (b && length xs >= n)
isCheap _ = False
isLifted :: E -> Bool
isLifted x = sortTermLike x && not (isUnboxed (getType x))
whnfOrBot :: E -> Bool
whnfOrBot (EError {}) = True
whnfOrBot (ELit LitCons { litArgs = xs }) = all isAtomic xs
whnfOrBot (EPi (TVr { tvrIdent = j, tvrType = x }) y) | not (j `member` (freeVars y :: IdSet)) = isAtomic x && isAtomic y
whnfOrBot ELam {} = True
whnfOrBot e | isAtomic e = True
whnfOrBot e | (EVar v,xs) <- fromAp e, Just (Arity n True) <- Info.lookup (tvrInfo v), length xs >= n = True
whnfOrBot _ = False
isUnboxed :: E -> Bool
isUnboxed e@EPi {} = False
isUnboxed e = getType e == eHash
safeToDup ec@ECase {}
| EVar _ <- eCaseScrutinee ec = all safeToDup (caseBodies ec)
| EPrim p _ _ <- eCaseScrutinee ec, primIsCheap p = all safeToDup (caseBodies ec)
safeToDup (EPrim p _ _) = primIsCheap p
safeToDup e = whnfOrBot e || isELam e || isEPi e
eToPat e = f e where
f (ELit LitCons { litAliasFor = af, litName = x, litArgs = ts, litType = t }) = do
ts <- mapM cv ts
return litCons { litAliasFor = af, litName = x, litArgs = ts, litType = t }
f (ELit (LitInt e t)) = return (LitInt e t)
f (EPi (TVr { tvrType = a}) b) = do
a <- cv a
b <- cv b
return litCons { litName = tc_Arrow, litArgs = [a,b], litType = eStar }
f x = fail $ "E.Values.eToPat: " ++ show x
cv (EVar v) = return v
cv e = fail $ "E.Value.eToPat.cv: " ++ show e
patToE p = f p where
f LitCons { litName = arr, litArgs = [a,b], litType = t} | t == eStar = return $ EPi tvr { tvrType = EVar a } (EVar b)
f (LitCons { litAliasFor = af, litName = x, litArgs = ts, litType = t }) = do
return $ ELit litCons { litAliasFor = af, litName = x, litArgs = map EVar ts, litType = t }
f (LitInt e t) = return $ ELit (LitInt e t)