X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fext-core%2FLanguage%2FCore%2FCoreUtils.hs;h=52d51f222a155c241de2397a295144ca5c3c0e90;hp=afe4039c25a1afc9ca8db3ba89823290d6a41b44;hb=e6232609a0b08ff7136a479f2e2d7d2be5040b1d;hpb=78c209010058cd7669781de92068b64dd32caaea diff --git a/utils/ext-core/Language/Core/CoreUtils.hs b/utils/ext-core/Language/Core/CoreUtils.hs index afe4039..52d51f2 100644 --- a/utils/ext-core/Language/Core/CoreUtils.hs +++ b/utils/ext-core/Language/Core/CoreUtils.hs @@ -2,9 +2,13 @@ module Language.Core.CoreUtils where import Language.Core.Core import Language.Core.Utils +import Language.Core.Printer() + +--import Debug.Trace import Data.Generics import Data.List +import Data.Maybe splitDataConApp_maybe :: Exp -> Maybe (Qual Dcon, [Ty], [Exp]) splitDataConApp_maybe (Dcon d) = Just (d, [], []) @@ -56,11 +60,18 @@ vdefTys :: [Vdef] -> [Ty] vdefTys = map (\ (Vdef (_,t,_)) -> t) vdefgNames :: Vdefg -> [Var] -vdefgNames (Rec vds) = map (\ (Vdef ((_,v),_,_)) -> v) vds -vdefgNames (Nonrec (Vdef ((_,v),_,_))) = [v] +vdefgNames = snd . unzip . vdefgNamesQ + +vdefgNamesQ :: Vdefg -> [Qual Var] +vdefgNamesQ (Rec vds) = map (\ (Vdef (v,_,_)) -> v) vds +vdefgNamesQ (Nonrec (Vdef (v,_,_))) = [v] + vdefgTys :: Vdefg -> [Ty] vdefgTys (Rec vds) = map (\ (Vdef (_,t,_)) -> t) vds vdefgTys (Nonrec (Vdef (_,t,_))) = [t] +vdefgBodies :: Vdefg -> [Exp] +vdefgBodies (Rec vds) = map (\ (Vdef (_,_,e)) -> e) vds +vdefgBodies (Nonrec (Vdef (_,_,e))) = [e] vbNames :: [Vbind] -> [Var] vbNames = fst . unzip @@ -82,3 +93,120 @@ tdefNames = concatMap doOne doOne (Newtype qtc qtc1 _ _) = [qtc, qtc1] doCdef (Constr qdc _ _) = [qdc] +tdefDcons :: [Tdef] -> [Qual Var] +tdefDcons = concatMap doOne + where doOne (Data _ _ cds) = concatMap doCdef cds + doOne _ = [] + doCdef (Constr qdc _ _) = [qdc] + +tdefTcons :: [Tdef] -> [Qual Var] +tdefTcons = concatMap doOne + where doOne (Data qtc _ _) = [qtc] + doOne (Newtype qtc qtc1 _ _) = [qtc, qtc1] + +filterVdefgs :: (Vdef -> Bool) -> [Vdefg] -> [Vdefg] +filterVdefgs ok = catMaybes . (map dropNames) + where dropNames (Nonrec v) | not (ok v) = Nothing + dropNames v@(Nonrec _) = Just v + dropNames (Rec bs) = case filter ok bs of + [] -> Nothing + newBs -> Just (Rec newBs) + +applyNewtype :: CoercionKind -> [Ty] -> (Ty,Ty) +applyNewtype _d@(DefinedCoercion tbs (from,to)) tys = + let (tvs,_) = unzip tbs in + let res = (substl tvs tys from,substl tvs tys to) in + -- trace ("co = " ++ show d ++ " args = " ++ show tys ++ " res = " ++ show res) $ + res + +{- Simultaneous substitution on types for type variables, + renaming as neceessary to avoid capture. + No checks for correct kindedness. -} +substl :: [Tvar] -> [Ty] -> Ty -> Ty +substl tvs ts t = f (zip tvs ts) t + where + f env t0 = + case t0 of + Tcon _ -> t0 + Tvar v -> case lookup v env of + Just t1 -> t1 + Nothing -> t0 + Tapp t1 t2 -> Tapp (f env t1) (f env t2) + Tforall (tv,k) t1 -> + if tv `elem` free then + Tforall (t',k) (f ((tv,Tvar t'):env) t1) + else + Tforall (tv,k) (f (filter ((/=tv).fst) env) t1) + TransCoercion t1 t2 -> TransCoercion (f env t1) (f env t2) + SymCoercion t1 -> SymCoercion (f env t1) + UnsafeCoercion t1 t2 -> UnsafeCoercion (f env t1) (f env t2) + LeftCoercion t1 -> LeftCoercion (f env t1) + RightCoercion t1 -> RightCoercion (f env t1) + InstCoercion t1 t2 -> InstCoercion (f env t1) (f env t2) + where free = foldr union [] (map (freeTvars.snd) env) + t' = freshTvar free + + +{- Return free tvars in a type -} +freeTvars :: Ty -> [Tvar] +freeTvars (Tcon _) = [] +freeTvars (Tvar v) = [v] +freeTvars (Tapp t1 t2) = freeTvars t1 `union` freeTvars t2 +freeTvars (Tforall (t,_) t1) = delete t (freeTvars t1) +freeTvars (TransCoercion t1 t2) = freeTvars t1 `union` freeTvars t2 +freeTvars (SymCoercion t) = freeTvars t +freeTvars (UnsafeCoercion t1 t2) = freeTvars t1 `union` freeTvars t2 +freeTvars (LeftCoercion t) = freeTvars t +freeTvars (RightCoercion t) = freeTvars t +freeTvars (InstCoercion t1 t2) = freeTvars t1 `union` freeTvars t2 + +{- Return any tvar *not* in the argument list. -} +freshTvar :: [Tvar] -> Tvar +freshTvar tvs = maximum ("":tvs) ++ "x" -- one simple way! + +splitLambda :: Exp -> ([Bind],Exp) +splitLambda (Lam vb e) = case splitLambda e of + (vbs,rhs) -> (vb:vbs,rhs) +splitLambda (Note _ e) = splitLambda e +splitLambda e = ([],e) + +vbinds :: [Bind] -> [(Var,Ty)] +vbinds = foldl' stuff [] + where stuff :: [(Var,Ty)] -> Bind -> [(Var,Ty)] + stuff rest (Tb _) = rest + stuff rest (Vb p) = p:rest + +splitBinds :: [Bind] -> ([(Tvar,Kind)],[(Var,Ty)]) +splitBinds = foldr stuff ([],[]) + where stuff (Tb t) (tbs,vbs) = (t:tbs,vbs) + stuff (Vb v) (tbs,vbs) = (tbs,v:vbs) + +freeVars :: Exp -> [Qual Var] +freeVars (Var v) = [v] +freeVars (Dcon _) = [] +freeVars (Lit _) = [] +freeVars (App f g) = freeVars f `union` freeVars g +freeVars (Appt e _) = freeVars e +freeVars (Lam (Tb _) e) = freeVars e +freeVars (Lam (Vb (v,_)) e) = delete (unqual v) (freeVars e) +freeVars (Let (Nonrec (Vdef (v,_,rhs))) e) = freeVars rhs `union` (delete v (freeVars e)) +freeVars (Let r@(Rec _) e) = (freeVars e \\ boundVars) `union` (freeVarss rhss \\ boundVars) + where boundVars = map unqual $ vdefgNames r + rhss = vdefgBodies r +freeVars (Case e (v,_) _ alts) = freeVars e `union` (delete v1 (boundVarsAlts alts)) + where v1 = unqual v + boundVarsAlts as = freeVarss rhss \\ (v1:caseVars) + where rhss = map (\ a -> case a of + Acon _ _ _ r -> r + Alit _ r -> r + Adefault r -> r) as + caseVars = foldl' union [] (map (\ a -> case a of + Acon _ _ vbs _ -> + (map unqual (fst (unzip vbs))) + _ -> []) as) +freeVars (Cast e _) = freeVars e +freeVars (Note _ e) = freeVars e +freeVars (External {}) = [] + +freeVarss :: [Exp] -> [Qual Var] +freeVarss = foldl' union [] . map freeVars \ No newline at end of file