External Core lib: lots of cleanup

- Factor out code for applying newtypes from Check into CoreUtils
- Use this code in Prep, which allowed for some simplification
- Change Merge and ElimDeadCode to not flatten top-level binds
- Add a flag for elimDeadCode to tell it whether to keep
exported bindings or not.
- Other things.

8 files changed, 225 insertions, 166 deletions

diff --git a/utils/ext-core/Language/Core/Check.hs b/utils/ext-core/Language/Core/Check.hs
index 2331ea0632..9f7a27670d 100644
--- a/utils/ext-core/Language/Core/Check.hs
+++ b/utils/ext-core/Language/Core/Check.hs
@@ -7,7 +7,10 @@ module Language.Core.Check(
   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
@@ -43,25 +46,22 @@ require False s = fail s
 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) = 
@@ -72,8 +72,7 @@ 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.
@@ -93,8 +92,7 @@ envsModule globalEnv (Module mn tdefs vdefgs) =
               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
@@ -102,12 +100,12 @@ 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''
@@ -128,7 +126,7 @@ processTdef0NoChecking tcenv tdef = ch tdef
 
 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))),
@@ -139,12 +137,12 @@ checkTdef tcenv cenv = ch
        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" ++
@@ -156,7 +154,7 @@ checkTdef tcenv cenv = ch
 					  (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) 
@@ -209,7 +207,7 @@ checkVdefg top_level (tcenv,tvenv,cenv) (e_venv,l_venv) vdefg = do
       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
@@ -223,8 +221,8 @@ checkVdefg top_level (tcenv,tvenv,cenv) (e_venv,l_venv) vdefg = do
                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))]
@@ -311,7 +309,7 @@ checkExp (tcenv,tvenv,cenv,e_venv,l_venv) = ch
 		 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)
@@ -347,7 +345,7 @@ checkExp (tcenv,tvenv,cenv,e_venv,l_venv) = ch
 		      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" ++
@@ -413,7 +411,7 @@ checkAlt (env@(tcenv,tvenv,cenv,e_venv,l_venv)) t0 = ch
 			  ("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
@@ -430,7 +428,11 @@ checkAlt (env@(tcenv,tvenv,cenv,e_venv,l_venv)) t0 = ch
 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
@@ -443,11 +445,11 @@ checkTy es@(tcenv,tvenv) = ch
                  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
@@ -456,7 +458,7 @@ checkTy es@(tcenv,tvenv) = ch
                      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
@@ -521,17 +523,17 @@ checkTyCo es@(tcenv,_) t@(Tapp t1 t2) =
  -- 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
@@ -552,15 +554,17 @@ checkTyCo es t = 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: "
@@ -568,9 +572,27 @@ mlookupM selector external_env local_env (Just m) = do
 
 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) =
@@ -603,50 +625,6 @@ splitTy (Tapp(Tapp(Tcon tc) t0) t) | tc == tcArrow = (tbs,t0:ts,tr)
 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
 
diff --git a/utils/ext-core/Language/Core/CoreUtils.hs b/utils/ext-core/Language/Core/CoreUtils.hs
index 2967cd64dc..52d51f222a 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
@@ -93,3 +104,109 @@ 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
diff --git a/utils/ext-core/Language/Core/ElimDeadCode.hs b/utils/ext-core/Language/Core/ElimDeadCode.hs
index e32568e5ef..8817edba10 100644
--- a/utils/ext-core/Language/Core/ElimDeadCode.hs
+++ b/utils/ext-core/Language/Core/ElimDeadCode.hs
@@ -7,6 +7,7 @@ module Language.Core.ElimDeadCode(elimDeadCode) where
 
 import Language.Core.Core
 import Language.Core.Printer()
+import Language.Core.CoreUtils
 import Language.Core.Utils
 
 import Control.Monad.Reader
@@ -16,12 +17,15 @@ import Data.Maybe
 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)
 
@@ -82,20 +86,19 @@ varsAndConsInOne' tc = do
 
 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])
diff --git a/utils/ext-core/Language/Core/Merge.hs b/utils/ext-core/Language/Core/Merge.hs
index 0907aa7f6e..18ad057791 100644
--- a/utils/ext-core/Language/Core/Merge.hs
+++ b/utils/ext-core/Language/Core/Merge.hs
@@ -11,6 +11,7 @@ import Language.Core.Utils
 import Data.Char
 import Data.Generics
 import Data.List
+import Data.Maybe
 
 {-
    merge turns a group of (possibly mutually recursive) modules
@@ -38,7 +39,7 @@ import Data.List
 
 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
@@ -46,7 +47,7 @@ merge subst ms =
                                              -> (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
@@ -61,9 +62,9 @@ merge subst ms =
    (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
@@ -149,5 +150,6 @@ finishTdefs namesToDrop = filter isOkay
             && 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)
diff --git a/utils/ext-core/Language/Core/Prep.hs b/utils/ext-core/Language/Core/Prep.hs
index 86b01550d2..a557b805e5 100644
--- a/utils/ext-core/Language/Core/Prep.hs
+++ b/utils/ext-core/Language/Core/Prep.hs
@@ -13,6 +13,8 @@ After these preprocessing steps, Core can be interpreted (or given an operationa
 
 module Language.Core.Prep where
 
+--import Debug.Trace
+
 import Control.Monad.State
 import Data.Either
 import Data.List
@@ -20,6 +22,7 @@ import Data.Generics
 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
@@ -97,8 +100,6 @@ prepModule globalEnv (Module mn tdefs vdefgs) =
     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)
@@ -110,41 +111,9 @@ prepModule globalEnv (Module mn tdefs vdefgs) =
 	      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'
@@ -241,36 +210,21 @@ boundVarsAlt (Acon _ _ vbs e) = (map fst vbs) `union` (boundVars 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
diff --git a/utils/ext-core/Language/Core/Printer.hs b/utils/ext-core/Language/Core/Printer.hs
index 4fef8543fa..d7c4cdbd21 100644
--- a/utils/ext-core/Language/Core/Printer.hs
+++ b/utils/ext-core/Language/Core/Printer.hs
@@ -35,6 +35,11 @@ instance Show Ty where
 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)
 
diff --git a/utils/ext-core/Language/Core/Utils.hs b/utils/ext-core/Language/Core/Utils.hs
index 3ffabf287b..d5ca785b21 100644
--- a/utils/ext-core/Language/Core/Utils.hs
+++ b/utils/ext-core/Language/Core/Utils.hs
@@ -33,7 +33,7 @@ everywhere'But :: GenericQ Bool -> GenericT -> GenericT
 -- 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
diff --git a/utils/ext-core/extcore.cabal b/utils/ext-core/extcore.cabal
index 5a6b7dc5f2..bb17b81ca8 100644
--- a/utils/ext-core/extcore.cabal
+++ b/utils/ext-core/extcore.cabal
@@ -13,8 +13,8 @@ data-files:          README
 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