X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FMkExternalCore.lhs;h=ba0c198209af5203a187f67cd016e525716fcf63;hp=337b21a8f0ff09c5fad947879e40c32ca37c723b;hb=b0045fdd4404f3ac2ddacad8c39a017f01f8ff6b;hpb=4c6a3f787abcaed009a574196d82237d9ae64fc8

diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs
index 337b21a..ba0c198 100644
--- a/compiler/coreSyn/MkExternalCore.lhs
+++ b/compiler/coreSyn/MkExternalCore.lhs
@@ -63,9 +63,18 @@ mkExternalCore :: CgGuts -> C.Module
 -- not been injected, so we have to add them manually here
 -- We don't include the strange data-con *workers* because they are
 -- implicit in the data type declaration itself
-mkExternalCore (CgGuts {cg_module=this_mod, cg_tycons = tycons, cg_binds = binds})
-  = (C.Module mname tdefs (runCoreM (mapM (make_vdef True) binds) 
-                            this_mod))
+mkExternalCore (CgGuts {cg_module=this_mod, cg_tycons = tycons, 
+                        cg_binds = binds})
+ -- Note that we flatten binds at the top level:
+ -- every module is just a single recursive bag of declarations.
+ -- Rationale: since modules can be mutually recursive, 
+ -- there's not much reason to preserve dependency info within a module.
+  = C.Module mname tdefs (case flattenBinds binds of
+                          -- check for empty list so we don't create an
+                          -- empty Rec group
+                            [] -> []
+                            bs  -> [(runCoreM (make_vdef True
+                                      (Rec bs)) this_mod)])
   where
     mname  = make_mid this_mod
     tdefs  = foldr collect_tdefs [] tycons
@@ -95,7 +104,11 @@ collect_tdefs tcon tdefs
         -- See Note [Newtype coercions] in 
         -- types/TyCon
         Just (arity,coKindFun) | (l,r) <- (coKindFun $ map mkTyVarTy vs) -> 
-            (vs,l,r) where vs = take arity tyvars
+             -- Here we eta-expand the newtype coercion,
+             -- which makes the ext-core typechecker somewhat simpler.
+            (tyvars,mkAppTys l extraVs,mkAppTys r extraVs)
+               where (vs, extraVs) = (take arity tyvars,
+                        map mkTyVarTy $ drop arity tyvars)
         Nothing -> pprPanic "MkExternalCore: coercion tcon lacks a kind fun"
                      (ppr tcon)
 
@@ -257,7 +270,9 @@ make_kind _ = error "MkExternalCore died: make_kind"
 {- Id generation. -}
 
 make_id :: Bool -> Name -> C.Id
-make_id _is_var nm = (occNameString . nameOccName) nm
+-- include uniques for internal names in order to avoid name shadowing
+make_id _is_var nm = ((occNameString . nameOccName) nm)
+  ++ (if isInternalName nm then (show . nameUnique) nm else "")
 
 make_var_id :: Name -> C.Id
 make_var_id = make_id True