X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FMkExternalCore.lhs;h=66fa9711e31c9d935be4336eb85a3014b9a5f0ad;hb=f1f24b1290313eb2105b162170cf84e92e939492;hp=47eb59b708ade235fa521fcf5c5d2519f95cfe13;hpb=e8f681e4b0294bf44ba50df80559112c769242ce;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs
index 47eb59b..66fa971 100644
--- a/ghc/compiler/coreSyn/MkExternalCore.lhs
+++ b/ghc/compiler/coreSyn/MkExternalCore.lhs
@@ -18,21 +18,21 @@ import TyCon
 import Class
 import TypeRep
 import Type
-import DataCon
+import PprExternalCore	-- Instances
+import DataCon	( DataCon, dataConExistentialTyVars, dataConRepArgTys, 
+		  dataConName, dataConWrapId_maybe )
 import CoreSyn
 import Var
 import IdInfo
-import Id( idUnfolding )
-import CoreTidy( tidyExpr )
-import VarEnv( emptyTidyEnv )
+import Id	( idUnfolding )
+import CoreTidy	( tidyExpr )
+import VarEnv	( emptyTidyEnv )
 import Literal
 import Name
-import CostCentre
 import Outputable
 import ForeignCall
-import PprExternalCore	
 import CmdLineOpts
-import Maybes( orElse )
+import Maybes	( mapCatMaybes )
 import IO
 import FastString
 
@@ -72,11 +72,11 @@ mkExternalCore (ModGuts {mg_module=this_mod, mg_types = type_env, mg_binds = bin
     other_implicit_binds  = map get_defn (concatMap other_implicit_ids (typeEnvElts type_env))
 
 implicit_con_ids :: TyThing -> [Id]
-implicit_con_ids (ATyCon tc) = map dataConWrapId (tyConDataCons_maybe tc `orElse` [])
-implicit_con_ids other       = []
+implicit_con_ids (ATyCon tc) | isAlgTyCon tc = mapCatMaybes 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 (ATyCon tc) = tyConSelIds tc
 other_implicit_ids (AClass cl) = classSelIds cl
 other_implicit_ids other       = []
 
@@ -95,6 +95,7 @@ collect_tdefs tcon tdefs
   where
     tdef | isNewTyCon tcon = 
                 C.Newtype (make_con_qid (tyConName tcon)) (map make_tbind tyvars) repclause 
+         | null (tyConDataCons tcon) = error "MkExternalCore died: can't handle datatype declarations with no data constructors"
          | otherwise = 
                 C.Data (make_con_qid (tyConName tcon)) (map make_tbind tyvars) (map make_cdef (tyConDataCons tcon)) 
          where repclause | isRecursiveTyCon tcon = Nothing
@@ -108,7 +109,7 @@ collect_tdefs _ tdefs = tdefs
 make_cdef :: DataCon -> C.Cdef
 make_cdef dcon =  C.Constr dcon_name existentials tys
   where 
-    dcon_name    = make_con_qid (dataConName dcon)
+    dcon_name    = make_var_id (dataConName dcon)
     existentials = map make_tbind ex_tyvars
     ex_tyvars    = dataConExistentialTyVars dcon
     tys 	 = map make_ty (dataConRepArgTys dcon)
@@ -124,7 +125,8 @@ make_vdef b =
   case b of
     NonRec v e -> C.Nonrec (f (v,e))
     Rec ves -> C.Rec (map f ves)
-  where f (v,e) = (make_var_qid (Var.varName v), make_ty (varType v),make_exp e)
+  where f (v,e) = (make_var_id (Var.varName v), make_ty (varType v),make_exp e)
+	-- Top level bindings are unqualified now
 
 make_exp :: CoreExpr -> C.Exp
 make_exp (Var v) =  
@@ -134,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 _))) = error "MkExternalCore died: can't handle \"foreign label\" declarations"
 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)
@@ -145,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"
 
@@ -163,8 +166,9 @@ make_lit l =
   case l of
     MachChar i | i <= 0xff -> C.Lchar (chr i) t
     MachChar i | otherwise -> C.Lint (toEnum i) t
+	-- For big characters, use an integer literal with a character type sig
     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
@@ -176,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: predTypeRep 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 (NewTcApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) 
+					 (map make_ty ts)
+
+make_ty (PredTy p)	= make_ty (predTypeRep p)
+make_ty (NoteTy _ t) 	= make_ty t
+
 
 
 make_kind :: Kind -> C.Kind