module Grin.Grin(
Callable(..),
Exp(..),
FuncDef(..),
FuncProps(..),
Grin(..),
TyThunk(..),
Lam(..),
Phase(..),
BaseOp(..),
Tag,
updateFuncDefProps,
Ty(..),
TyEnv(..),
TyTy(..),
tyTy,
Val(..),
Var(..),
extendTyEnv,
createFuncDef,
setGrinFunctions,
grinFuncs,
emptyGrin,
tyINode,
tyDNode,
findArgs,
findArgsType,
findTyTy,
gEval,
grinEntryPointNames,
isHole,
isValUnknown,
isVar,
n0,n1,n2,n3,
p0,p1,p2,p3,
partialTag,
phaseEvalInlined,
properHole,
tagFlipFunction,
tagHole,
tagInfo,
TagInfo(..),
tagIsFunction,
tagIsPartialAp,
tagIsSuspFunction,
tagIsTag,
tagIsWHNF,
tagToFunction,
tagUnfunction,
v0,v1,v2,v3,lamExp,lamBind,
valIsNF
) where
import Control.Monad.Identity
import Data.Char
import Data.Monoid(Monoid(..))
import Data.List(isPrefixOf)
import qualified Data.Set as Set
import C.FFI
import C.Prims
import Cmm.Number
import Doc.DocLike
import Name.VConsts
import Options
import StringTable.Atom
import Support.CanType
import Support.FreeVars
import Util.GMap
import Util.Gen
import Util.HasSize
import Util.Perhaps
import Util.SetLike
import qualified Cmm.Op as Op
import qualified Info.Info as Info
import qualified Stats
infixr 1 :->, :>>=
data BaseOp
= Demote
| Promote
| Eval
| Apply [Ty]
| StoreNode !Bool
| Redirect
| Overwrite
| PeekVal
| PokeVal
| Consume
| GcTouch
| Coerce Ty
| GcPush
| NewRegister
| ReadRegister
| WriteRegister
deriving(Eq,Ord,Show)
data Lam = [Val] :-> Exp
deriving(Eq,Ord,Show)
data Exp =
Exp :>>= Lam
| BaseOp { expBaseOp :: BaseOp,
expArgs :: [Val]
}
| App { expFunction :: Atom,
expArgs :: [Val],
expType :: [Ty] }
| Prim { expPrimitive :: Prim,
expArgs :: [Val],
expType :: [Ty] }
| Case { expValue :: Val, expAlts :: [Lam] }
| Return { expValues :: [Val] }
| Error { expError :: String, expType :: [Ty] }
| Call { expValue :: Val,
expArgs :: [Val],
expType :: [Ty],
expJump :: Bool,
expFuncProps :: FuncProps,
expInfo :: Info.Info }
| NewRegion { expLam :: Lam, expInfo :: Info.Info }
| Alloc { expValue :: Val,
expCount :: Val,
expRegion :: Val,
expInfo :: Info.Info }
| Let { expDefs :: [FuncDef],
expBody :: Exp,
expFuncCalls :: (Set.Set Atom,Set.Set Atom),
expIsNormal :: Bool,
expNonNormal :: Set.Set Atom,
expInfo :: Info.Info }
| MkClosure { expValue :: Val,
expArgs :: [Val],
expRegion :: Val,
expType :: [Ty],
expInfo :: Info.Info }
| MkCont { expCont :: Lam,
expLam :: Lam,
expInfo :: Info.Info }
| GcRoots { expValues :: [Val],
expBody :: Exp }
deriving(Eq,Show,Ord)
data Val =
NodeC !Tag [Val]
| Const Val
| Lit !Number Ty
| Var !Var Ty
| Unit
| ValPrim Prim [Val] Ty
| Index Val Val
| Item Atom Ty
| ValUnknown Ty
deriving(Eq,Ord)
data Ty =
TyPtr Ty
| TyNode
| TyINode
| TyAttr Ty Ty
| TyAnd Ty Ty
| TyOr Ty Ty
| TyPrim Op.Ty
| TyUnit
| TyCall Callable [Ty] [Ty]
| TyRegion
| TyGcContext
| TyRegister Ty
| TyComplex Ty
| TyVector !Int Ty
| TyUnknown
deriving(Eq,Ord)
data Callable = Continuation | Function | Closure | LocalFunction | Primitive'
deriving(Eq,Ord,Show)
type Tag = Atom
newtype Var = V Int
deriving(Eq,Ord,Enum)
data FuncDef = FuncDef {
funcDefName :: Atom,
funcDefBody :: Lam,
funcDefCall :: Val,
funcDefProps :: FuncProps
} deriving(Eq,Ord,Show)
data TyThunk
= TyNotThunk
| TyPApp (Maybe Ty) Atom
| TySusp Atom
deriving(Eq,Show)
data TyTy = TyTy {
tySlots :: [Ty],
tyReturn :: [Ty],
tyThunk :: TyThunk,
tySiblings :: Maybe [Atom]
}
tyTy = TyTy { tySlots = [], tyReturn = [], tySiblings = Nothing, tyThunk = TyNotThunk }
newtype TyEnv = TyEnv (GMap Atom TyTy)
deriving(Monoid)
lamExp (_ :-> e) = e
lamBind (b :-> _) = b
isVar Var {} = True
isVar _ = False
tagHole = toAtom "@hole"
gEval :: Val -> Exp
gEval x = BaseOp Eval [x]
tyINode = TyINode
tyDNode = TyNode
createFuncDef local name body@(args :-> rest) = updateFuncDefProps FuncDef { funcDefName = name, funcDefBody = body, funcDefCall = call, funcDefProps = funcProps } where
call = Item name (TyCall (if local then LocalFunction else Function) (map getType args) (getType rest))
updateFuncDefProps fd@FuncDef { funcDefBody = body@(args :-> rest) } = fd { funcDefProps = props } where
props = (funcDefProps fd) { funcFreeVars = freeVars body, funcTags = freeVars body, funcType = (map getType args,getType rest) }
grinFuncs grin = map (\x -> (funcDefName x, funcDefBody x)) (grinFunctions grin)
setGrinFunctions xs _grin | flint && hasRepeatUnder fst xs = error $ "setGrinFunctions: grin has redundent definitions" ++ show (fsts xs)
setGrinFunctions xs grin = grin { grinFunctions = map (uncurry (createFuncDef False)) xs }
extendTyEnv ds (TyEnv env) = TyEnv (fromList xs `mappend` env) where
xs = [ (funcDefName d,tyTy { tySlots = ss, tyReturn = r }) | d <- ds, let (ss,r) = funcType $ funcDefProps d]
++ [ (tagFlipFunction (funcDefName d),tyTy { tySlots = ss, tyReturn = r }) | d <- ds, let (ss,r) = funcType $ funcDefProps d, r == [TyNode]]
data FuncProps = FuncProps {
funcInfo :: Info.Info,
funcFreeVars :: Set.Set Var,
funcTags :: Set.Set Tag,
funcType :: ([Ty],[Ty]),
funcExits :: Perhaps,
funcCuts :: Perhaps,
funcAllocs :: Perhaps,
funcCreates :: Perhaps,
funcLoops :: Perhaps
}
deriving(Eq,Ord,Show)
funcProps = FuncProps {
funcInfo = mempty,
funcFreeVars = mempty,
funcTags = mempty,
funcType = undefined,
funcExits = Maybe,
funcCuts = Maybe,
funcAllocs = Maybe,
funcCreates = Maybe,
funcLoops = Maybe
}
data Phase = PhaseInit | PostInlineEval | PostAeOptimize | PostDevolve
deriving(Show,Eq,Ord,Enum)
phaseEvalInlined e = e >= PostInlineEval
data Grin = Grin {
grinEntryPoints :: GMap Atom FfiExport,
grinPhase :: !Phase,
grinTypeEnv :: TyEnv,
grinFunctions :: [FuncDef],
grinSuspFunctions :: Set.Set Atom,
grinPartFunctions :: Set.Set Atom,
grinStats :: !Stats.Stat,
grinCafs :: [(Var,Val)]
}
emptyGrin = Grin {
grinEntryPoints = mempty,
grinPhase = PhaseInit,
grinTypeEnv = mempty,
grinFunctions = [],
grinSuspFunctions = mempty,
grinPartFunctions = mempty,
grinStats = mempty,
grinCafs = mempty
}
grinEntryPointNames = keys . grinEntryPoints
data TagInfo
= TagPApp !Int !Atom
| TagSusp !Bool !Atom
| TagDataCons
| TagTypeCons
| TagTypePApp !Int Tag
| TagFunc
tagInfo t = case fromAtom t of
'F':xs -> TagSusp True (toAtom $ 'f':xs)
'B':xs -> TagSusp True (toAtom $ 'b':xs)
'f':_ -> TagFunc
'b':_ -> TagFunc
'C':_ -> TagDataCons
'T':_ -> TagTypeCons
'P':is | (n@(_:_),('_':xs)) <- span isDigit is -> TagPApp (read n) (toAtom $ 'f':xs)
'Y':is | (n@(_:_),('_':xs)) <- span isDigit is -> TagTypePApp (read n) (toAtom $ 'T':xs)
t -> error $ "tagInfo: bad tag " ++ t
partialTag :: Tag -> Int -> Tag
partialTag v c = case fromAtom v of
('f':xs) | 0 <- c -> toAtom $ 'F':xs
| c > 0 -> toAtom $ 'P':show c ++ "_" ++ xs
('T':xs) | 0 <- c -> v
| c > 0 -> toAtom $ 'Y':show c ++ "_" ++ xs
('b':xs) | 0 <- c -> toAtom $ 'B':xs
_ -> error $ "partialTag: " ++ show (v,c)
tagUnfunction :: Monad m => Tag -> m (Int, Tag)
tagUnfunction t
| tagIsSuspFunction t = return (0,tagFlipFunction t)
| tagIsFunction t = return (0,t)
| ('P':zs) <- t', (n@(_:_),'_':rs) <- span isDigit zs = return (read n, toAtom ('f':rs))
where t' = fromAtom t
tagUnfunction _ = fail "Tag does not represent function"
tagFlipFunction t
| 'F':xs <- t' = toAtom $ 'f':xs
| 'B':xs <- t' = toAtom $ 'b':xs
| 'f':xs <- t' = toAtom $ 'F':xs
| 'b':xs <- t' = toAtom $ 'B':xs
| otherwise = error "Cannot FLIP non function."
where t' = fromAtom t
tagIsSuspFunction t
| 'F':_ <- t' = True
| 'B':_ <- t' = True
| otherwise = False
where t' = fromAtom t
tagToFunction t
| 'F':xs <- t' = return $ toAtom $ 'f':xs
| 'B':xs <- t' = return $ toAtom $ 'b':xs
| 'f':_ <- t' = return t
| 'b':_ <- t' = return t
| 'P':is <- t', ('_':xs) <- dropWhile isDigit is = return $ toAtom $ 'f':xs
| otherwise = fail $ "Not Function: " ++ t'
where t' = fromAtom t
tagIsFunction t
| 'f':_ <- t' = True
| 'b':_ <- t' = True
| otherwise = False
where t' = fromAtom t
tagIsPartialAp t
| 'P':_ <- t' = True
| otherwise = False
where t' = fromAtom t
tagIsTag t
| 'P':_ <- t' = True
| 'T':_ <- t' = True
| 'C':_ <- t' = True
| 'F':_ <- t' = True
| 'B':_ <- t' = True
| 'Y':_ <- t' = True
| otherwise = False
where t' = fromAtom t
tagIsWHNF t
| 'P':_ <- t' = True
| 'T':_ <- t' = True
| 'C':_ <- t' = True
| 'Y':_ <- t' = True
| otherwise = False
where t' = fromAtom t
valIsNF (NodeC t vs) = tagIsWHNF t && all valIsNF vs
valIsNF Const {} = True
valIsNF Lit {} = True
valIsNF _ = False
properHole x = case x of
TyINode -> Const (properHole TyNode)
ty@(TyPrim _) -> (Lit 0 ty)
~TyNode -> (NodeC tagHole [])
isHole x = x `elem` map properHole [TyINode, TyNode]
isValUnknown ValUnknown {} = True
isValUnknown _ = False
findTyTy (TyEnv m) a | Just tyty <- mlookup a m = return tyty
findTyTy (TyEnv m) a | ('Y':rs) <- fromAtom a, (ns,'_':rs) <- span isDigit rs = case mlookup (toAtom ('T':rs)) m of
Just TyTy { tySlots = ts, tyReturn = n } -> return tyTy { tySlots = take (length ts read ns) ts, tyReturn = n }
Nothing -> fail $ "findArgsType: " ++ show a
findTyTy _ a | "@hole" `isPrefixOf` fromAtom a = return tyTy { tySlots = [], tyReturn = [TyNode] }
findTyTy _ a = fail $ "findArgsType: " ++ show a
findArgsType m a = liftM (\tyty -> (tySlots tyty,tyReturn tyty)) (findTyTy m a)
findArgs m a = case findArgsType m a of
Nothing -> fail $ "findArgs: " ++ show a
Just (as,_) -> return as
v0 = V 0
v1 = V 1
v2 = V 2
v3 = V 3
n0 = Var v0 TyNode
n1 = Var v1 TyNode
n2 = Var v2 TyNode
n3 = Var v3 TyNode
p0 = Var v0 TyINode
p1 = Var v1 TyINode
p2 = Var v2 TyINode
p3 = Var v3 TyINode
instance CanType Exp where
type TypeOf Exp = [Ty]
getType (_ :>>= (_ :-> e2)) = getType e2
getType (Prim _ _ ty) = ty
getType App { expType = t } = t
getType (BaseOp Overwrite _) = []
getType (BaseOp GcTouch _) = []
getType (BaseOp (Coerce t) _) = [t]
getType (BaseOp Redirect _) = []
getType (BaseOp Promote _) = [TyNode]
getType (BaseOp Demote _) = [TyINode]
getType (BaseOp Eval _) = [TyNode]
getType (BaseOp (StoreNode b) _) = if b then [TyNode] else [TyINode]
getType (BaseOp NewRegister xs) = map (TyRegister . getType) xs
getType (BaseOp WriteRegister _) = []
getType (BaseOp ReadRegister [r]) = case getType r of
TyRegister t -> [t]
_ -> error "Exp.getType: ReadRegister of non register"
getType (BaseOp (Apply ty) _) = ty
getType (BaseOp PeekVal [v]) = case getType v of
TyPtr t -> [t]
_ -> error "Exp.getType: PeekVal of non-pointer type"
getType (Return v) = getType v
getType (Error _ t) = t
getType (Case _ []) = error "empty case"
getType (Case _ ((_ :-> e):_)) = getType e
getType NewRegion { expLam = _ :-> body } = getType body
getType Alloc { expValue = v } = [TyPtr (getType v)]
getType Let { expBody = body } = getType body
getType MkCont { expLam = _ :-> rbody } = getType rbody
getType Call { expType = ty } = ty
getType MkClosure { expType = ty } = ty
getType GcRoots { expBody = body } = getType body
getType _ = error "Exp.getType: bad."
instance CanType Val where
type TypeOf Val = Ty
getType (Var _ t) = t
getType (Lit _ t) = t
getType (Index v _) = getType v
getType Unit = TyUnit
getType (Const t) = case (getType t) of
TyNode -> TyINode
t -> error "Val.getType: Const of non-node"
getType (NodeC {}) = TyNode
getType (ValPrim _ _ ty) = ty
getType (ValUnknown ty) = ty
getType (Item _ ty) = ty
instance FreeVars Lam (Set.Set Var) where
freeVars (x :-> y) = freeVars y Set.\\ freeVars x
instance FreeVars Lam (Set.Set (Var,Ty)) where
freeVars (x :-> y) = freeVars y Set.\\ freeVars x
instance FreeVars Exp (Set.Set Var,Set.Set Tag) where
freeVars x = (freeVars x, freeVars x)
instance FreeVars Val (Set.Set Var) where
freeVars (NodeC t xs) = freeVars xs
freeVars (Const v) = freeVars v
freeVars (Index a b) = freeVars (a,b)
freeVars (Var v _) = Set.singleton v
freeVars _ = Set.empty
instance FreeVars Val (Set.Set (Var,Ty)) where
freeVars (NodeC t xs) = freeVars xs
freeVars (Const v) = freeVars v
freeVars (Index a b) = freeVars (a,b)
freeVars (Var v t) = Set.singleton (v,t)
freeVars _ = Set.empty
instance FreeVars FuncProps (Set.Set Var) where
freeVars FuncProps { funcFreeVars = fv } = fv
instance FreeVars FuncProps (Set.Set Tag) where
freeVars FuncProps { funcTags = fv } = fv
instance FreeVars FuncProps a => FreeVars FuncDef a where
freeVars fd = freeVars (funcDefProps fd)
instance FreeVars Exp (Set.Set Var) where
freeVars (a :>>= b) = freeVars (a,b)
freeVars (App a vs _) = freeVars vs
freeVars (Case x xs) = freeVars (x,xs)
freeVars (Return v) = freeVars v
freeVars (BaseOp _ vs) = freeVars vs
freeVars (Prim _ x _) = freeVars x
freeVars Error {} = Set.empty
freeVars Let { expDefs = fdefs, expBody = body } = mconcat (map (funcFreeVars . funcDefProps) fdefs) `mappend` freeVars body
freeVars NewRegion { expLam = l } = freeVars l
freeVars Alloc { expValue = v, expCount = c, expRegion = r } = freeVars (v,c,r)
freeVars Call { expValue = v, expArgs = as } = freeVars (v:as)
freeVars MkClosure { expValue = v, expArgs = as, expRegion = r } = freeVars (v,as,r)
freeVars MkCont { expCont = v, expLam = as} = freeVars (v,as)
freeVars GcRoots { expValues = v, expBody = b } = freeVars (v,b)
instance FreeVars Exp (Set.Set (Var,Ty)) where
freeVars (a :>>= b) = freeVars (a,b)
freeVars (App a vs _) = freeVars vs
freeVars (Case x xs) = freeVars (x,xs)
freeVars (Return v) = freeVars v
freeVars (BaseOp _ vs) = freeVars vs
freeVars (Prim _ x _) = freeVars x
freeVars Error {} = Set.empty
freeVars Let { expDefs = fdefs, expBody = body } = mconcat (map (freeVars . funcDefBody) fdefs) `mappend` freeVars body
freeVars NewRegion { expLam = l } = freeVars l
freeVars Alloc { expValue = v, expCount = c, expRegion = r } = freeVars (v,c,r)
freeVars Call { expValue = v, expArgs = as } = freeVars (v:as)
freeVars MkClosure { expValue = v, expArgs = as, expRegion = r } = freeVars (v,as,r)
freeVars MkCont { expCont = v, expLam = as} = freeVars (v,as)
freeVars GcRoots { expValues = v, expBody = b } = freeVars (v,b)
instance FreeVars Val (Set.Set Tag) where
freeVars (NodeC t xs) = Set.singleton t `Set.union` freeVars xs
freeVars (Index a b) = freeVars (a,b)
freeVars (Const v) = freeVars v
freeVars _ = Set.empty
instance FreeVars Val [Tag] where
freeVars v = Set.toList $ freeVars v
instance FreeVars Exp [Tag] where
freeVars v = Set.toList $ freeVars v
instance FreeVars Lam (Set.Set Tag) where
freeVars (a :-> b) = freeVars (a,b)
instance FreeVars Exp (Set.Set Tag) where
freeVars (a :>>= b) = freeVars (a,b)
freeVars (App a vs _) = Set.singleton a `Set.union` freeVars vs
freeVars (Case x xs) = freeVars (x,xs)
freeVars (Return v) = freeVars v
freeVars (BaseOp _ vs) = freeVars vs
freeVars (Prim _ x _) = freeVars x
freeVars Error {} = Set.empty
freeVars Let { expDefs = fdefs, expBody = body } = mconcat (map (funcTags . funcDefProps) fdefs) `mappend` freeVars body
freeVars NewRegion { expLam = l } = freeVars l
freeVars Alloc { expValue = v, expCount = c, expRegion = r } = freeVars (v,c,r)
freeVars Call { expValue = v, expArgs = as } = freeVars (v:as)
freeVars MkClosure { expValue = v, expArgs = as, expRegion = r } = freeVars (v,as,r)
freeVars MkCont { expCont = v, expLam = as} = freeVars (v,as)
freeVars GcRoots { expValues = v, expBody = b } = freeVars (v,b)
instance FreeVars Lam (GSet Var) where
freeVars (x :-> y) = freeVars y \\ freeVars x
instance FreeVars Exp (GSet Var,GSet Tag) where
freeVars x = (freeVars x, freeVars x)
instance FreeVars Val (GSet Var) where
freeVars (NodeC t xs) = freeVars xs
freeVars (Const v) = freeVars v
freeVars (Index a b) = freeVars (a,b)
freeVars (Var v _) = singleton v
freeVars _ = sempty
instance FreeVars FuncProps (GSet Var) where
freeVars FuncProps { funcFreeVars = fv } = fromDistinctAscList $ toList fv
instance FreeVars FuncProps (GSet Tag) where
freeVars FuncProps { funcTags = fv } = fromDistinctAscList $ toList fv
instance FreeVars Exp (GSet Var) where
freeVars (a :>>= b) = freeVars (a,b)
freeVars (App a vs _) = freeVars vs
freeVars (Case x xs) = freeVars (x,xs)
freeVars (Return v) = freeVars v
freeVars (BaseOp _ vs) = freeVars vs
freeVars (Prim _ x _) = freeVars x
freeVars Error {} = sempty
freeVars Let { expDefs = fdefs, expBody = body } = mconcat (map (fromDistinctAscList . toList . funcFreeVars . funcDefProps) fdefs) `mappend` freeVars body
freeVars NewRegion { expLam = l } = freeVars l
freeVars Alloc { expValue = v, expCount = c, expRegion = r } = freeVars (v,c,r)
freeVars Call { expValue = v, expArgs = as } = freeVars (v:as)
freeVars MkClosure { expValue = v, expArgs = as, expRegion = r } = freeVars (v,as,r)
freeVars MkCont { expCont = v, expLam = as} = freeVars (v,as)
freeVars GcRoots { expValues = v, expBody = b } = freeVars (v,b)
instance FreeVars Exp [Var] where
freeVars e = toList $ (freeVars e :: GSet Var)
instance FreeVars Val [Var] where
freeVars e = toList $ (freeVars e :: GSet Var)
instance FreeVars Lam [Var] where
freeVars e = toList $ (freeVars e :: GSet Var)
instance FreeVars Val (GSet Tag) where
freeVars (NodeC t xs) = singleton t `union` freeVars xs
freeVars (Index a b) = freeVars (a,b)
freeVars (Const v) = freeVars v
freeVars _ = sempty
instance FreeVars Lam (GSet Tag) where
freeVars (a :-> b) = freeVars (a,b)
instance FreeVars Exp (GSet Tag) where
freeVars (a :>>= b) = freeVars (a,b)
freeVars (App a vs _) = singleton a `union` freeVars vs
freeVars (Case x xs) = freeVars (x,xs)
freeVars (Return v) = freeVars v
freeVars (BaseOp _ vs) = freeVars vs
freeVars (Prim _ x _) = freeVars x
freeVars Error {} = sempty
freeVars Let { expDefs = fdefs, expBody = body } = unions (map (fromDistinctAscList . toList . funcTags . funcDefProps) fdefs) `mappend` freeVars body
freeVars NewRegion { expLam = l } = freeVars l
freeVars Alloc { expValue = v, expCount = c, expRegion = r } = freeVars (v,c,r)
freeVars Call { expValue = v, expArgs = as } = freeVars (v:as)
freeVars MkClosure { expValue = v, expArgs = as, expRegion = r } = freeVars (v,as,r)
freeVars MkCont { expCont = v, expLam = as} = freeVars (v,as)
freeVars GcRoots { expValues = v, expBody = b } = freeVars (v,b)
instance Show Var where
showsPrec _ (V n) xs = 'v':shows n xs
instance Show Ty where
showsPrec n (TyComplex ty) = showParen (n >= 9) $ text "Complex" <+> showsPrec 10 ty
showsPrec n (TyVector v ty) = showParen (n >= 9) $ showsPrec 10 ty <> text "*" <> tshow v
showsPrec n (TyAttr t1 t2) = showParen (n >= 9) $ showsPrec 10 t1 <> text "#" <> showsPrec 10 t2
showsPrec n (TyAnd t1 t2) = showParen (n >= 9) $ showsPrec 10 t1 <> text " && " <> showsPrec 10 t2
showsPrec n (TyOr t1 t2) = showParen (n >= 9) $ showsPrec 10 t1 <> text " || " <> showsPrec 10 t2
showsPrec _ t = showString (f t) where
f TyNode = "N"
f TyINode = "I"
f (TyPtr t) = '&':show t
f (TyUnit) = "()"
f (TyPrim t) = show t
f TyRegion = "M"
f TyGcContext = "GC"
f (TyRegister t) = 'r':show t
f (TyCall c as rt) = show c <> tupled (map show as) <+> "->" <+> show rt
f TyUnknown = "?"
f _ = "BADTYPE"
instance Show Val where
showsPrec _ (NodeC t []) = parens $ (fromAtom t)
showsPrec _ (NodeC t vs) = parens $ (fromAtom t) <+> hsep (map shows vs)
showsPrec _ (Index v o) = shows v <> char '[' <> shows o <> char ']'
showsPrec _ (Var (V i) t)
| TyINode <- t = text "ni" <> tshow i
| TyNode <- t = text "nd" <> tshow i
| TyRegion <- t = text "m" <> tshow i
| TyRegister ty <- t = text "r" <> tshow (Var (V i) ty)
| TyGcContext <- t = text "gc" <> tshow i
| TyPtr t' <- t = text "p" <> shows (Var (V i) t')
| TyPrim Op.TyBool <- t = char 'b' <> tshow i
| TyPrim (Op.TyBits _ Op.HintFloat) <- t = char 'f' <> tshow i
| TyPrim (Op.TyBits _ Op.HintCharacter) <- t = char 'c' <> tshow i
| TyPrim (Op.TyBits (Op.Bits 8) _) <- t = char 'o' <> tshow i
| TyPrim (Op.TyBits (Op.Bits 16) _) <- t = char 'h' <> tshow i
| TyPrim (Op.TyBits (Op.Bits 32) _) <- t = char 'w' <> tshow i
| TyPrim (Op.TyBits (Op.Bits 64) _) <- t = char 'd' <> tshow i
| TyPrim (Op.TyBits (Op.Bits 128) _) <- t = char 'q' <> tshow i
| TyPrim (Op.TyBits (Op.BitsArch Op.BitsPtr) _) <- t = text "bp" <> tshow i
| TyPrim (Op.TyBits (Op.BitsArch Op.BitsMax) _) <- t = text "bm" <> tshow i
| TyPrim (Op.TyBits _ _) <- t = char 'l' <> tshow i
| otherwise = char 'v' <> tshow i
showsPrec _ (Lit i _) = tshow i
showsPrec _ Unit = showString "()"
showsPrec _ (Const v) = char '&' <> shows v
showsPrec _ (Item a ty) = tshow a <> text "::" <> tshow ty
showsPrec _ (ValUnknown ty) = text "?::" <> tshow ty
showsPrec _ (ValPrim aprim xs _) = tshow aprim <> tupled (map tshow xs)
instance TypeNames Ty where
tIntzh = TyPrim (Op.bits32)
tEnumzh = TyPrim (Op.bits16)
tCharzh = TyPrim (Op.bits32)
instance Intjection Var where
toIntjection i = V (fromIntegral i)
fromIntjection (V i) = fromIntegral i
newtype instance GSet Var = GSetVar (IntjectionSet Var)
deriving(Monoid,IsEmpty,HasSize,Collection,Unionize,SetLike,Eq,Ord)
newtype instance GMap Var v = GMapVar (IntjectionMap Var v)
deriving(Monoid,IsEmpty,HasSize,Collection,Unionize,SetLike,MapLike,Eq,Ord)