X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fext-core%2FLanguage%2FCore%2FMerge.hs;h=18ad057791a6a0e22952b3d9875f6798a90ac81a;hp=b5ffd05cf248b533894150ea2adfc6e9a3a79a39;hb=e6232609a0b08ff7136a479f2e2d7d2be5040b1d;hpb=78c209010058cd7669781de92068b64dd32caaea

diff --git a/utils/ext-core/Language/Core/Merge.hs b/utils/ext-core/Language/Core/Merge.hs
index b5ffd05..18ad057 100644
--- a/utils/ext-core/Language/Core/Merge.hs
+++ b/utils/ext-core/Language/Core/Merge.hs
@@ -2,7 +2,7 @@
    This module combines multiple External Core modules into
    a single module, including both datatype and value definitions. 
 -}
-module Language.Core.Merge(merge) where
+module Language.Core.Merge(merge,uniqueNamesIn,nonUniqueNamesIn) where
 
 import Language.Core.Core
 import Language.Core.CoreUtils
@@ -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,12 +62,20 @@ 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 (flattenBinds topBinds)
+        dcons = tdefDcons allTdefs
+        tcons = tdefTcons allTdefs
+        uniqueVars  = vars \\ dupsUnqual vars
+        uniqueDcons = dcons \\ dupsUnqual dcons
+        uniqueTcons = tcons \\ dupsUnqual tcons
+        res = uniqueVars ++ uniqueDcons ++ uniqueTcons
+
+nonUniqueNamesIn :: [Vdef] -> [Tdef] -> [Qual Var]
+nonUniqueNamesIn topBinds allTdefs = dupsUnqual allNames
   where allNames = vdefNamesQ topBinds ++ tdefNames allTdefs
-        dups     = dupsUnqual allNames
-        res      = allNames \\ dups
-
+        
 -- This takes each top-level name of the form Foo.Bar.blah and
 -- renames it to FoozuBarzublah (note we *don't* make it exported!
 -- This is so we know which names were in the original program and
@@ -92,11 +101,9 @@ fixupName subst _ oldVar | Just newVar <- lookup oldVar subst = newVar
 -- We don't alter unqualified names, since we just need to make sure
 -- everything can go in the Main module.
 fixupName _ _ vr@(Nothing,_) = vr
--- Nor do we alter anything defined in the Main module
--- or in the primitive or Bool modules
--- (because we basically treat the Bool type as primitive.)
+-- Nor do we alter anything defined in the Main module or the primitive module.
 fixupName _ _ vr@(Just mn, _) | mn == mainMname || mn == wrapperMainMname ||
-                            mn == primMname || mn == boolMname = vr
+                            mn == primMname = vr
 -- For a variable that is defined by only one module in scope, we 
 -- give it a name that is just its unqualified name, without the original
 -- module and package names.
@@ -143,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)