X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FMkExternalCore.lhs;h=569655c727a190b327610914cbd4c96f02f372e4;hb=6c2e162376df87192b7a65461f452a776e7f5116;hp=0f37564eea130f45c7c5fb4d88b5e4dc76bb2d4b;hpb=6ddd83ed3708374cdc06a6eafbb5714b5b8934b4;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs
index 0f37564..569655c 100644
--- a/ghc/compiler/coreSyn/MkExternalCore.lhs
+++ b/ghc/compiler/coreSyn/MkExternalCore.lhs
@@ -18,11 +18,15 @@ import TyCon
 import Class
 import TypeRep
 import Type
-import DataCon
+import DataCon	( DataCon, dataConExistentialTyVars, dataConRepArgTys, 
+		  dataConName, dataConWrapId_maybe )
 import CoreSyn
 import Var
 import IdInfo
-import Id( idUnfolding )
+import Id	( idUnfolding )
+import CoreTidy	( tidyExpr )
+import VarEnv	( emptyTidyEnv )
+import TysPrim	( intPrimTy )
 import Literal
 import Name
 import CostCentre
@@ -30,7 +34,7 @@ import Outputable
 import ForeignCall
 import PprExternalCore	
 import CmdLineOpts
-import Maybes( orElse )
+import Maybes	( orElse, catMaybes )
 import IO
 import FastString
 
@@ -38,7 +42,7 @@ emitExternalCore :: DynFlags -> ModGuts -> IO ()
 emitExternalCore dflags mod_impl
  | opt_EmitExternalCore 
  = (do handle <- openFile corename WriteMode
-       hPutStr handle (show (mkExternalCore mod_impl))      
+       hPutStrLn handle (show (mkExternalCore mod_impl))      
        hClose handle)
    `catch` (\err -> pprPanic "Failed to open or write external core output file" 
 	                     (text corename))
@@ -49,26 +53,43 @@ emitExternalCore _ _
 
 
 mkExternalCore :: ModGuts -> C.Module
+-- The ModGuts has been tidied, but the implicit bindings have
+-- 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 (ModGuts {mg_module=this_mod, mg_types = type_env, mg_binds = binds})
-  = C.Module mname tdefs vdefs
+  = C.Module mname tdefs (map make_vdef all_binds)
   where
     mname  = make_mid this_mod
     tdefs  = foldr collect_tdefs [] tycons
-    vdefs  = map make_vdef (implicit_binds ++ binds)
+
+    all_binds  = implicit_con_wrappers ++ other_implicit_binds ++ binds
+		-- Put the constructor wrappers first, because
+		-- other implicit bindings (notably the fromT functions arising 
+		-- from generics) use the constructor wrappers.
+
     tycons = map classTyCon (typeEnvClasses type_env) ++ typeEnvTyCons type_env
 
-	-- Don't forget to include the implicit bindings!
-    implicit_binds = map get_defn (concatMap implicit_ids (typeEnvElts type_env))
+    implicit_con_wrappers = map get_defn (concatMap implicit_con_ids   (typeEnvElts type_env))
+    other_implicit_binds  = map get_defn (concatMap other_implicit_ids (typeEnvElts type_env))
 
-implicit_ids :: TyThing -> [Id]
--- C.f. HscTypes.mkImplicitBinds, but we do not include constructor workers
-implicit_ids (ATyCon tc) = map dataConWrapId (tyConDataCons_maybe tc `orElse` [])
-				 ++ tyConSelIds tc ++ tyConGenIds tc
-implicit_ids (AClass cl) = classSelIds cl
-implicit_ids other       = []
+implicit_con_ids :: TyThing -> [Id]
+implicit_con_ids (ATyCon tc) | isAlgTyCon tc = catMaybes (map dataConWrapId_maybe (tyConDataCons tc))
+implicit_con_ids other       		     = []
+
+other_implicit_ids :: TyThing -> [Id]
+other_implicit_ids (ATyCon tc) = tyConSelIds tc ++ tyConGenIds tc
+other_implicit_ids (AClass cl) = classSelIds cl
+other_implicit_ids other       = []
 
 get_defn :: Id -> CoreBind
-get_defn id = NonRec id (unfoldingTemplate (idUnfolding id))
+get_defn id = NonRec id rhs
+	    where
+	      rhs  = tidyExpr emptyTidyEnv body 
+	      body = unfoldingTemplate (idUnfolding id)
+	-- Don't forget to tidy the body !  Otherwise you get silly things like
+	--	\ tpl -> case tpl of tpl -> (tpl,tpl) -> tpl
+	-- Maybe we should inject these bindings during CoreTidy?
 
 collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
 collect_tdefs tcon tdefs 
@@ -115,7 +136,7 @@ make_exp (Var v) =
     FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.External (unpackFS nm) (make_ty (varType v))
     FCallId _ -> error "MkExternalCore died: can't handle non-static-C foreign call"
     _ -> C.Var (make_var_qid (Var.varName v))
-make_exp (Lit (l@(MachLabel s))) = C.External (unpackFS s) (make_ty (literalType l))
+make_exp (Lit (l@(MachLabel s _))) = C.External (unpackFS s) (make_ty (literalType l))
 make_exp (Lit l) = C.Lit (make_lit l)
 make_exp (App e (Type t)) = C.Appt (make_exp e) (make_ty t)
 make_exp (App e1 e2) = C.App (make_exp e1) (make_exp e2)
@@ -126,6 +147,7 @@ make_exp (Case e v alts) = C.Case (make_exp e) (make_vbind v) (map make_alt alts
 make_exp (Note (SCC cc) e) = C.Note "SCC"  (make_exp e) -- temporary
 make_exp (Note (Coerce t_to t_from) e) = C.Coerce (make_ty t_to) (make_exp e)
 make_exp (Note InlineCall e) = C.Note "InlineCall" (make_exp e)
+make_exp (Note (CoreNote s) e) = C.Note s (make_exp e)  -- hdaume: core annotations
 make_exp (Note InlineMe e) = C.Note "InlineMe" (make_exp e)
 make_exp _ = error "MkExternalCore died: make_exp"
 
@@ -143,9 +165,10 @@ make_lit :: Literal -> C.Lit
 make_lit l = 
   case l of
     MachChar i | i <= 0xff -> C.Lchar (chr i) t
-    MachChar i | otherwise -> C.Lint (toEnum i) t
+    MachChar i | otherwise -> C.Lint (toEnum i) (make_ty intPrimTy)
+	-- For 'big' characters, use an integer
     MachStr s -> C.Lstring (unpackFS s) t
-    MachAddr i -> C.Lint i t  
+    MachNullAddr -> C.Lint 0 t
     MachInt i -> C.Lint i t
     MachInt64 i -> C.Lint i t
     MachWord i -> C.Lint i t
@@ -157,13 +180,30 @@ make_lit l =
     t = make_ty (literalType l)
 
 make_ty :: Type -> C.Ty
-make_ty (TyVarTy tv) = C.Tvar (make_var_id (tyVarName tv))
-make_ty (AppTy t1 t2) = C.Tapp (make_ty t1) (make_ty t2)
-make_ty (TyConApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) (map make_ty ts)
-make_ty (FunTy t1 t2) = make_ty (TyConApp funTyCon [t1,t2])
-make_ty (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t)
-make_ty (SourceTy p) = make_ty (sourceTypeRep p)
-make_ty (NoteTy _ t) = make_ty t
+make_ty (TyVarTy tv)    	 = C.Tvar (make_var_id (tyVarName tv))
+make_ty (AppTy t1 t2) 		 = C.Tapp (make_ty t1) (make_ty t2)
+make_ty (FunTy t1 t2) 		 = make_ty (TyConApp funTyCon [t1,t2])
+make_ty (ForAllTy tv t) 	 = C.Tforall (make_tbind tv) (make_ty t)
+make_ty (TyConApp tc ts) 	 = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) 
+					 (map make_ty ts)
+-- The special case for newtypes says "do not expand newtypes".
+-- Reason: sourceTypeRep does substitution and, while substitution deals
+-- 	   correctly with name capture, it's only correct if you see the uniques!
+--	   If you just see occurrence names, name capture may occur.
+-- Example: newtype A a = A (forall b. b -> a)
+--	    test :: forall q b. q -> A b
+--	    test _ = undefined
+-- 	Here the 'a' gets substituted by 'b', which is captured.
+-- Another solution would be to expand newtypes before tidying; but that would
+-- expose the representation in interface files, which definitely isn't right.
+-- Maybe CoreTidy should know whether to expand newtypes or not?
+
+make_ty (SourceTy (NType tc ts)) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) 
+					 (map make_ty ts)
+
+make_ty (SourceTy p)		 = make_ty (sourceTypeRep p)
+make_ty (NoteTy _ t) 		 = make_ty t
+
 
 
 make_kind :: Kind -> C.Kind