[project @ 2001-07-20 16:48:20 by simonpj]

[ghc-hetmet.git] / ghc / compiler / coreSyn / MkExternalCore.lhs

diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs
index e5f5f4f..9b0a507 100644 (file)
--- a/ghc/compiler/coreSyn/MkExternalCore.lhs
+++ b/ghc/compiler/coreSyn/MkExternalCore.lhs
@@ -11,7 +11,6 @@ module MkExternalCore (
 
 import qualified ExternalCore as C
 import Char
-import Ratio
 import Module
 import CoreSyn
 import HscTypes        
@@ -22,13 +21,10 @@ import DataCon
 import CoreSyn
 import Var
 import IdInfo
-import NameEnv
 import Literal
 import Name
 import CostCentre
 import Outputable
-import PrimOp
-import Class
 import ForeignCall
 import PprExternalCore 
 import CmdLineOpts
@@ -90,14 +86,18 @@ collect_exports tyenv (AvailTC n ns) (tcons,dcons,vars) =
 
 
 collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
-collect_tdefs tcon tdefs | isAlgTyCon tcon = tdef:tdefs
-  where 
-    tdef = 
-      case newTyConRep tcon of
-        Just rep -> 
-          C.Newtype (make_con_id (tyConName tcon)) (map make_tbind (tyConTyVars tcon)) (make_ty rep)
-        Nothing -> 
-          C.Data (make_con_id (tyConName tcon)) (map make_tbind (tyConTyVars tcon)) (map make_cdef (tyConDataCons tcon))
+collect_tdefs tcon tdefs 
+  | isAlgTyCon tcon = tdef: tdefs
+  where
+    tdef | isNewTyCon tcon = 
+                C.Newtype (make_con_id (tyConName tcon)) (map make_tbind tyvars) repclause 
+         | otherwise = 
+                C.Data (make_con_id (tyConName tcon)) (map make_tbind tyvars) (map make_cdef (tyConDataCons tcon)) 
+         where repclause | isRecursiveTyCon tcon = Nothing
+                        | otherwise = Just (make_ty rep)
+                                           where (_, rep) = newTyConRep tcon
+    tyvars = tyConTyVars tcon
+
 collect_tdefs _ tdefs = tdefs
 
 
@@ -153,7 +153,8 @@ make_alt (DEFAULT,[],e) = C.Adefault (make_exp e)
 make_lit :: Literal -> C.Lit
 make_lit l = 
   case l of
-    MachChar i -> C.Lchar (chr i) t
+    MachChar i | i <= 0xff -> C.Lchar (chr i) t
+    MachChar i | otherwise -> C.Lint (toEnum i) t
     MachStr s -> C.Lstring (_UNPK_ s) t
     MachAddr i -> C.Lint i t  
     MachInt i -> C.Lint i t
@@ -173,26 +174,28 @@ 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 (PredTy p) = make_ty (predRepTy p)
+make_ty (SourceTy p) = make_ty (sourceTypeRep p)
 make_ty (UsageTy _ t) = make_ty t
 make_ty (NoteTy _ t) = make_ty t
 
 
 make_kind :: Kind -> C.Kind
 make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2)
-make_kind k | k == liftedTypeKind = C.Klifted
-make_kind k | k == unliftedTypeKind = C.Kunlifted
-make_kind k | k == openTypeKind = C.Kopen
+make_kind k | k `eqKind` liftedTypeKind = C.Klifted
+make_kind k | k `eqKind` unliftedTypeKind = C.Kunlifted
+make_kind k | k `eqKind` openTypeKind = C.Kopen
 make_kind _ = error "MkExternalCore died: make_kind"
 
 {- Id generation. -}
 
-{- Use encoded strings, except restore non-leading '#'s.
+{- Use encoded strings, except restore '#'s.
    Also, adjust casing to work around some badly-chosen internal names. -}
 make_id :: Bool -> Name -> C.Id
 make_id is_var nm = 
   case n of
-    c:cs -> if isUpper c && is_var then (toLower c):(decode cs) else (decode n)
+    c:cs -> if isUpper c && is_var then (toLower c):(decode cs) 
+           else if isLower c && (not is_var) then (toUpper c):(decode cs)
+            else decode n
   where n = (occNameString . nameOccName) nm
         decode ('z':'h':cs) = '#':(decode cs)
         decode (c:cs) = c:(decode cs)