CheckRes(..), splitTy, substl,
mkTypeEnvsNoChecking) where
+--import Debug.Trace
+
import Language.Core.Core
+import Language.Core.CoreUtils
import Language.Core.Printer()
import Language.Core.PrimEnv
import Language.Core.Env
require True _ = return ()
-extendM :: (Ord a, Show a) => EnvType -> Env a b -> (a,b) -> CheckResult (Env a b)
-extendM envType env (k,d) =
+extendM :: (Ord a, Show a) => Bool -> EnvType -> Env a b -> (a,b) -> CheckResult (Env a b)
+extendM checkNameShadowing envType env (k,d) =
case elookup env k of
- Just _ | envType == NotTv -> fail ("multiply-defined identifier: "
+ Just _ | envType == NotTv && checkNameShadowing -> fail ("multiply-defined identifier: "
++ show k)
_ -> return (eextend env (k,d))
-extendVenv :: (Ord a, Show a) => Env a b -> (a,b) -> CheckResult (Env a b)
-extendVenv = extendM NotTv
+extendVenv :: (Ord a, Show a) => Bool -> Env a b -> (a,b) -> CheckResult (Env a b)
+extendVenv check = extendM check NotTv
extendTvenv :: (Ord a, Show a) => Env a b -> (a,b) -> CheckResult (Env a b)
-extendTvenv = extendM Tv
+extendTvenv = extendM True Tv
-lookupM :: (Ord a, Show a) => Env a b -> a -> CheckResult b
-lookupM env k =
- case elookup env k of
- Just v -> return v
- Nothing -> fail ("undefined identifier: " ++ show k ++ " e = " ++ show (edomain env))
-
+lookupM :: (Ord a, Show a) => Env a b -> a -> CheckResult (Maybe b)
+lookupM env k = return $ elookup env k
+
{- Main entry point. -}
checkModule :: Menv -> Module -> CheckRes Menv
checkModule globalEnv (Module mn tdefs vdefgs) =
vdefgs
return (eextend globalEnv
(mn,Envs{tcenv_=tcenv,cenv_=cenv,venv_=e_venv})))
- -- avoid name shadowing
- (mn, eremove globalEnv mn)
+ (mn, globalEnv)
-- Like checkModule, but doesn't typecheck the code, instead just
-- returning declared types for top-level defns.
add :: [(Qual Var,Ty)] -> Venv -> Venv
add pairs e = foldr addOne e pairs
addOne :: (Qual Var, Ty) -> Venv -> Venv
- addOne ((Nothing,_),_) e = e
- addOne ((Just _,v),t) e = eextend e (v,t)
+ addOne ((_,v),t) e = eextend e (v,t)
checkTdef0 :: Tcenv -> Tdef -> CheckResult Tcenv
checkTdef0 tcenv tdef = ch tdef
ch (Data (m,c) tbs _) =
do mn <- getMname
requireModulesEq m mn "data type declaration" tdef False
- extendM NotTv tcenv (c, Kind k)
+ extendM True NotTv tcenv (c, Kind k)
where k = foldr Karrow Klifted (map snd tbs)
ch (Newtype (m,c) coVar tbs rhs) =
do mn <- getMname
requireModulesEq m mn "newtype declaration" tdef False
- tcenv' <- extendM NotTv tcenv (c, Kind k)
+ tcenv' <- extendM True NotTv tcenv (c, Kind k)
-- add newtype axiom to env
tcenv'' <- envPlusNewtype tcenv' (m,c) coVar tbs rhs
return tcenv''
envPlusNewtype :: Tcenv -> Qual Tcon -> Qual Tcon -> [Tbind] -> Ty
-> CheckResult Tcenv
-envPlusNewtype tcenv tyCon coVar tbs rep = extendM NotTv tcenv
+envPlusNewtype tcenv tyCon coVar tbs rep = extendM True NotTv tcenv
(snd coVar, Coercion $ DefinedCoercion tbs
(foldl Tapp (Tcon tyCon)
(map Tvar (fst (unzip tbs))),
where
ch (Data (_,c) utbs cdefs) =
do cbinds <- mapM checkCdef cdefs
- foldM (extendM NotTv) cenv cbinds
+ foldM (extendM True NotTv) cenv cbinds
where checkCdef (cdef@(Constr (m,dcon) etbs ts)) =
do mn <- getMname
requireModulesEq m mn "constructor declaration" cdef
False
- tvenv <- foldM (extendM Tv) eempty tbs
+ tvenv <- foldM (extendM True Tv) eempty tbs
ks <- mapM (checkTy (tcenv,tvenv)) ts
mapM_ (\k -> require (baseKind k)
("higher-order kind in:\n" ++ show cdef ++ "\n" ++
(foldl Tapp (Tcon (Just mn,c))
(map (Tvar . fst) utbs)) ts) tbs
ch (tdef@(Newtype tc _ tbs t)) =
- do tvenv <- foldM (extendM Tv) eempty tbs
+ do tvenv <- foldM (extendM True Tv) eempty tbs
kRhs <- checkTy (tcenv,tvenv) t
require (kRhs `eqKind` Klifted) ("bad kind:\n" ++ show tdef)
kLhs <- checkTy (tcenv,tvenv)
case vdefg of
Rec vdefs ->
do (e_venv', l_venv') <- makeEnv mn vdefs
- let env' = (tcenv,tvenv,cenv,e_venv',l_venv')
+ let env' = (tcenv,tvenv,cenv,e_venv',l_venv')
mapM_ (checkVdef (\ vdef k -> require (k `eqKind` Klifted)
("unlifted kind in:\n" ++ show vdef)) env')
vdefs
makeEnv mn [vdef]
where makeEnv mn vdefs = do
- ev <- foldM extendVenv e_venv e_vts
- lv <- foldM extendVenv l_venv l_vts
+ ev <- foldM (extendVenv False) e_venv e_vts
+ lv <- foldM (extendVenv False) l_venv l_vts
return (ev, lv)
where e_vts = [ (v,t) | Vdef ((Just m,v),t,_) <- vdefs,
not (vdefIsMainWrapper mn (Just m))]
require (baseKind k)
("higher-order kind in:\n" ++ show e0 ++ "\n" ++
"kind: " ++ show k)
- l_venv' <- extendVenv l_venv vb
+ l_venv' <- extendVenv True l_venv vb
t <- checkExp (tcenv,tvenv,cenv,e_venv,l_venv') e
require (not (isUtupleTy vt)) ("lambda-bound unboxed tuple in:\n" ++ show e0)
return (tArrow vt t)
in ok as [l]
[Adefault _] -> return ()
_ -> fail ("no alternatives in case:\n" ++ show e0)
- l_venv' <- extendVenv l_venv (v,t)
+ l_venv' <- extendVenv True l_venv (v,t)
t:ts <- mapM (checkAlt (tcenv,tvenv,cenv,e_venv,l_venv') t) alts
require (all (== t) ts)
("alternative types don't match in:\n" ++ show e0 ++ "\n" ++
("pattern constructor type doesn't match scrutinee type in:\n" ++ show a0 ++ "\n" ++
"pattern constructor type: " ++ show ct_res ++ "\n" ++
"scrutinee type: " ++ show t0)
- l_venv' <- foldM extendVenv l_venv vbs
+ l_venv' <- foldM (extendVenv True) l_venv vbs
t <- checkExp (tcenv,tvenv',cenv,e_venv,l_venv') e
checkTy (tcenv,tvenv) t {- check that existentials don't escape in result type -}
return t
checkTy :: (Tcenv,Tvenv) -> Ty -> CheckResult Kind
checkTy es@(tcenv,tvenv) = ch
where
- ch (Tvar tv) = lookupM tvenv tv
+ ch (Tvar tv) = do
+ res <- lookupM tvenv tv
+ case res of
+ Just k -> return k
+ Nothing -> fail ("Undefined tvar: " ++ show tv)
ch (Tcon qtc) = do
kOrC <- qlookupM tcenv_ tcenv eempty qtc
case kOrC of
tcK <- qlookupM tcenv_ tcenv eempty tc
case tcK of
Kind _ -> checkTapp t1 t2
- Coercion (DefinedCoercion tbs (from,to)) -> do
+ Coercion co@(DefinedCoercion tbs _) -> do
-- makes sure coercion is fully applied
require (length tys == length tbs) $
("Arity mismatch in coercion app: " ++ show t)
- let (tvs, tks) = unzip tbs
+ let (_, tks) = unzip tbs
argKs <- mapM (checkTy es) tys
let kPairs = zip argKs tks
-- Simon says it's okay for these to be
require kindsOk
("Kind mismatch in coercion app: " ++ show tks
++ " and " ++ show argKs ++ " t = " ++ show t)
- return $ Keq (substl tvs tys from) (substl tvs tys to)
+ return $ (uncurry Keq) (applyNewtype co tys)
Nothing -> checkTapp t1 t2
where checkTapp t1 t2 = do
k1 <- ch t1
-- todo: avoid duplicating this code
-- blah, this almost calls for a different syntactic form
-- (for a defined-coercion app): (TCoercionApp Tcon [Ty])
- Coercion (DefinedCoercion tbs (from, to)) -> do
+ Coercion co@(DefinedCoercion tbs _) -> do
require (length tys == length tbs) $
("Arity mismatch in coercion app: " ++ show t)
- let (tvs, tks) = unzip tbs
+ let (_, tks) = unzip tbs
argKs <- mapM (checkTy es) tys
let kPairs = zip argKs tks
let kindsOk = all (uncurry subKindOf) kPairs
require kindsOk
("Kind mismatch in coercion app: " ++ show tks
++ " and " ++ show argKs ++ " t = " ++ show t)
- return (substl tvs tys from, substl tvs tys to)
+ return (applyNewtype co tys)
_ -> checkTapp t1 t2
_ -> checkTapp t1 t2)
where checkTapp t1 t2 = do
-- otherwise, expand by the "refl" rule
_ -> return (t, t)
-mlookupM :: (Eq a, Show a) => (Envs -> Env a b) -> Env a b -> Env a b -> Mname
+mlookupM :: (Eq a, Show a, Show b) => (Envs -> Env a b) -> Env a b -> Env a b -> Mname
-> CheckResult (Env a b)
-mlookupM _ _ local_env Nothing = return local_env
+mlookupM _ _ local_env Nothing = -- (trace ("mlookupM_: returning " ++ show local_env)) $
+ return local_env
mlookupM selector external_env local_env (Just m) = do
mn <- getMname
+ globalEnv <- getGlobalEnv
if m == mn
- then return external_env
- else do
- globalEnv <- getGlobalEnv
+ then -- trace ("global env would b e " ++ show (elookup globalEnv m)) $
+ return external_env
+ else
case elookup globalEnv m of
Just env' -> return (selector env')
Nothing -> fail ("Check: undefined module name: "
qlookupM :: (Ord a, Show a,Show b) => (Envs -> Env a b) -> Env a b -> Env a b
-> Qual a -> CheckResult b
-qlookupM selector external_env local_env (m,k) =
- do env <- mlookupM selector external_env local_env m
- lookupM env k
+qlookupM selector external_env local_env v@(m,k) =
+ do env <- -- trace ("qlookupM: " ++ show v) $
+ mlookupM selector external_env local_env m
+ -- argh, hack for unqualified top-level names
+ maybeRes <- lookupM env k
+ case maybeRes of
+ Just r -> return r
+ Nothing -> do mn <- getMname
+ currentMenv <- -- trace ("qlookupM: trying module for " ++ show mn) $
+ mlookupM selector external_env local_env (Just mn)
+ maybeRes1 <- -- trace ("qlookupM: trying in " ++ show currentMenv) $
+ lookupM currentMenv k
+ case maybeRes1 of
+ Just r1 -> return r1
+ Nothing -> do
+ globalEnv <- getGlobalEnv
+ case elookup globalEnv mn of
+ Just e1 -> case elookup (selector e1) k of
+ Just r2 -> return r2
+ Nothing -> fail ("Undefined id " ++ show v)
+ Nothing -> fail ("Undefined id " ++ show v)
checkLit :: Lit -> CheckResult Ty
checkLit (Literal lit t) =
splitTy t = ([],[],t)
-{- 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 (t,k) t1 ->
- if t `elem` free then
- Tforall (t',k) (f ((t,Tvar t'):env) t1)
- else
- Tforall (t,k) (f (filter ((/=t).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!
-
primCoercionError :: Show a => a -> b
primCoercionError s = error $ "Bad coercion application: " ++ show s
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, [], [])
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
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
import Language.Core.Core
import Language.Core.Printer()
+import Language.Core.CoreUtils
import Language.Core.Utils
import Control.Monad.Reader
import qualified Data.Map as M
import qualified Data.Set as S
-elimDeadCode :: Module -> Module
-elimDeadCode (Module mn tdefs vdefgs) = runReader (do
+elimDeadCode :: Bool -> Module -> Module
+-- exports = true <=> it's assumed we want to keep exported functions;
+-- otherwise, we assume the module is "closed" and eliminate everything
+-- not reachable from Main
+elimDeadCode exports (Module mn tdefs vdefgs) = runReader (do
(usedVars, usedDcons, usedTcons) <- findUsed emptySet
- (mkStartSet mn vdefgs)
+ (mkStartSet exports mn vdefgs)
let isUsed (Vdef (v,_,_)) = v `S.member` usedVars
- let newVdefgs = [Rec $ filter isUsed (flattenBinds vdefgs)]
+ let newVdefgs = filterVdefgs isUsed vdefgs
let newTdefs = filter (tdefIsUsed usedTcons usedDcons) tdefs in
return $ Module mn newTdefs newVdefgs) ((mkVarEnv vdefgs), mkTyEnv tdefs)
emptySet :: DeadSet
emptySet = (S.empty, S.empty, S.empty)
-mkStartSet :: AnMname -> [Vdefg] -> DeadSet
+mkStartSet :: Bool -> AnMname -> [Vdefg] -> DeadSet
-- Initially, we assume the definitions of any exported functions are not
-- dead, and work backwards from there.
-mkStartSet mn vds =
- (S.fromList (filter ((== Just mn) . getModule) (exportedNames vds)),
+mkStartSet exports mn vds =
+ (S.fromList (filter ((== Just mn) . getModule) (if exports then exportedNames vds else [mainVar])),
S.empty, S.empty)
exportedNames :: [Vdefg] -> [Qual Var]
exportedNames vdefgs =
let vds = flattenBinds vdefgs in
- filter isQual (vdefNames vds)
+ filter isQual (ns vds)
where isQual = isJust . fst
- vdefNames = map (\ (Vdef (n,_,_)) -> n)
-
+ ns = map (\ (Vdef (n,_,_)) -> n)
type DeadSet = (S.Set (Qual Var), S.Set (Qual Dcon), S.Set (Qual Tcon))
type DeadM = Reader (M.Map (Qual Var) Exp, M.Map (Qual Tcon) [Ty])
import Data.Char
import Data.Generics
import Data.List
+import Data.Maybe
{-
merge turns a group of (possibly mutually recursive) modules
merge :: [(Qual Var, Qual Var)] -> [Module] -> Module
merge subst ms =
- zapNames subst topNames (Module mainMname newTdefs [Rec topBinds])
+ zapNames subst topNames (Module mainMname newTdefs topBinds)
where -- note: dead code elimination will later remove any names
-- that were in the domain of the substitution
newTdefs = finishTdefs deadIds $ concat allTdefs
-> (tds, vdefgs)) ms
(deadIds,_) = unzip subst
topNames = uniqueNamesIn topBinds (concat allTdefs)
- topBinds = finishVdefs deadIds $ flattenBinds (concat allVdefgs)
+ (topBinds::[Vdefg]) = finishVdefs deadIds $ concat allVdefgs
{-
This function finds all of the names in the given group of vdefs and
(Both of those would allow for more names to be shortened, but aren't
strictly necessary.)
-}
-uniqueNamesIn :: [Vdef] -> [Tdef] -> [Qual Var]
+uniqueNamesIn :: [Vdefg] -> [Tdef] -> [Qual Var]
uniqueNamesIn topBinds allTdefs = res
- where vars = vdefNamesQ topBinds
+ where vars = vdefNamesQ (flattenBinds topBinds)
dcons = tdefDcons allTdefs
tcons = tdefTcons allTdefs
uniqueVars = vars \\ dupsUnqual vars
&& cdefsOkay cdefs
cdefsOkay = all cdefOkay
cdefOkay (Constr qdc _ _) = qdc `notElem` namesToDrop
-finishVdefs :: [Qual Var] -> [Vdef] -> [Vdef]
-finishVdefs namesToDrop = filter (\ (Vdef (qv,_,_)) -> qv `notElem` namesToDrop)
+finishVdefs :: [Qual Var] -> [Vdefg] -> [Vdefg]
+finishVdefs namesToDrop = filterVdefgs
+ (\ (Vdef (qv,_,_)) -> qv `notElem` namesToDrop)
module Language.Core.Prep where
+--import Debug.Trace
+
import Control.Monad.State
import Data.Either
import Data.List
import qualified Data.Map as M
import Language.Core.Core
+import Language.Core.CoreUtils
import Language.Core.Env
import Language.Core.Check
import Language.Core.Environments
prepAlt env (Alit l e) = (liftM (Alit l)) (prepExp env e)
prepAlt env (Adefault e) = (liftM Adefault) (prepExp env e)
- ntEnv = mkNtEnv globalEnv
-
unwindApp :: (Venv, Tvenv) -> Exp -> [Either Exp Ty] -> PrepM Exp
unwindApp env (App e1 e2) as = unwindApp env e1 (Left e2:as)
unwindApp env (Appt e t) as = unwindApp env e (Right t:as)
atys = map (substl (map fst tbs) ts) atys0
ts = [t | Right t <- as]
n = length [e | Left e <- as]
- unwindApp env (op@(Var(qv@(_,p)))) as | isPrimVar qv = do
+ unwindApp env (op@(Var qv)) as | isPrimVar qv = do
e' <- rewindApp env op as
- (liftM k) $ etaExpand (snd (unzip extraTbs)) (drop n atys) (k1 e')
- where -- TODO: avoid copying code. these two cases are the same
-
- -- etaExpand needs to add the type arguments too! Bah!
- primEnv = case elookup globalEnv primMname of
- Just es -> venv_ es
- _ -> error "eek"
- (_, _, resTy') = (maybe (error "unwindApp") splitTy (elookup primEnv p))
- (tbs, atys0, _resTy) = (maybe (error "unwindApp") (splitTy . (substNewtys ntEnv)) (elookup primEnv p))
- -- The magic here is so we know to eta-expand applications of
- -- primops whose return types are newtypes.
- -- There are no actual GHC primops that have this property, but
- -- a back-end tool writer (for example: me) might want to add
- -- such a primop.
- -- If this code wasn't here, and we had a primop
- -- foo# :: Int -> IO (),
- -- we would see (foo# 5) and think it was fully applied, when
- -- actually we need to rewrite it as:
- -- (\ (s::State# RealWorld#) -> foo# 5 s)
- -- (This code may be a very good case against introducing such
- -- primops.)
- -- tim 10/29/2008: I think this is no longer necessary.
- -- hPutChar now has a (#wub,blub#) return type.
- (k,k1) = case newtypeCoercion_maybe ntEnv resTy' of
- Just co -> case splitTyConApp_maybe resTy' of
- Just (_, args) -> ((\ e -> Cast e (SymCoercion (mkTapp co args))), (\ e1 -> Cast e1 (mkTapp co args)))
- _ -> ((\ e -> Cast e (SymCoercion co)), (\ e1 -> Cast e1 co))
- _ -> (id,id)
- n_args = length ts
- (appliedTbs, extraTbs) = (take n_args tbs, drop n_args tbs)
- atys = map (substl (map fst appliedTbs) ts) atys0
- ts = [t | Right t <- as]
- n = length [e | Left e <- as]
+ etaExpand [] [] e'
unwindApp env (op@(External _ t)) as = do
e' <- rewindApp env op as
etaExpand [] (drop n atys) e'
boundVarsAlt (Alit _ e) = boundVars e
boundVarsAlt (Adefault e) = boundVars e
-mkNtEnv :: Menv -> NtEnv
-mkNtEnv menv =
- foldl M.union M.empty $
- map (\ (mn,e) ->
- foldr (\ (key,thing) rest ->
- case thing of
- Kind _ -> rest
- Coercion (DefinedCoercion _ (lhs,rhs)) ->
- case splitTyConApp_maybe lhs of
- Just ((_,tc1),_) -> M.insert tc1 (rhs,Tcon (Just mn, key)) rest
- _ -> rest) M.empty (etolist (tcenv_ e))) (etolist menv)
-
substNewtys :: NtEnv -> Ty -> Ty
substNewtys ntEnv = everywhere'Except (mkT go)
- where go t | Just ((_,tc),_) <- splitTyConApp_maybe t =
+ where go t | Just ((_,tc),args) <- splitTyConApp_maybe t =
case M.lookup tc ntEnv of
- Just (rhs,_) -> rhs
+ Just d -> -- trace ("applying newtype: " ++ show t) $
+ (snd (applyNewtype d args))
Nothing -> t
go t = t
-newtypeCoercion_maybe :: NtEnv -> Ty -> Maybe Ty
-newtypeCoercion_maybe ntEnv t | Just ((_,tc),_) <- splitTyConApp_maybe t =
- case M.lookup tc ntEnv of
- Just (_, coercion) -> Just coercion
- Nothing -> Nothing
+newtypeCoercion_maybe :: NtEnv -> Ty -> Maybe CoercionKind
+newtypeCoercion_maybe ntEnv t | Just ((_,tc),_) <- splitTyConApp_maybe t =
+ M.lookup tc ntEnv
newtypeCoercion_maybe _ _ = Nothing
--- first element: rep type
--- second element: coercion tcon
-type NtEnv = M.Map Tcon (Ty, Ty)
+type NtEnv = M.Map Tcon CoercionKind
mkTapp :: Ty -> [Ty] -> Ty
mkTapp = foldl Tapp
instance Show Kind where
showsPrec _ k = shows (pkind k)
+instance Show CoercionKind where
+ showsPrec _ (DefinedCoercion tbs (from,to)) =
+ shows $ parens (text "defined coercion:" <+> (hsep (map ptbind tbs))
+ <+> text ":" <+> brackets (pty from)
+ <+> text "->" <+> brackets (pty to))
instance Show Lit where
showsPrec _ l = shows (plit l)
-- Guarded to let traversal cease if predicate q holds for x
everywhere'But q f x
| q x = x
- | otherwise = let top = gmapT f x in
+ | otherwise = let top = f x in
top `seq` (gmapT (everywhere'But q f) top)
everywhereButM :: Monad m => GenericQ Bool -> GenericM m -> GenericM m
build-type: Simple
cabal-version: >=1.2
Library {
- exposed-modules: Language.Core.Check, Language.Core.Dependencies, Language.Core.Core, Language.Core.Interp, Language.Core.Overrides, Language.Core.ParsecParser, Language.Core.Prep, Language.Core.Prims, Language.Core.Printer, Language.Core.Merge, Language.Core.ElimDeadCode, Language.Core.Encoding, Language.Core.Env
- other-modules: Language.Core.PrimCoercions, Language.Core.PrimEnv, Language.Core.Utils, Language.Core.CoreUtils, Language.Core.Environments
+ exposed-modules: Language.Core.Check, Language.Core.Dependencies, Language.Core.Core, Language.Core.Interp, Language.Core.Overrides, Language.Core.ParsecParser, Language.Core.Prep, Language.Core.Prims, Language.Core.Printer, Language.Core.Merge, Language.Core.ElimDeadCode, Language.Core.Encoding, Language.Core.Env, Language.Core.CoreUtils
+ other-modules: Language.Core.PrimCoercions, Language.Core.PrimEnv, Language.Core.Utils, Language.Core.Environments
extensions: DeriveDataTypeable PatternGuards RankNTypes ScopedTypeVariables
ghc-options: -Wall -O2
build-depends: base, containers, directory, filepath, mtl, parsec, pretty
projects / ghc-hetmet.git / commitdiff