X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=utils%2Fext-core%2FCore.hs;h=9df300e010a3519522f4d2e9e2fe523149a59275;hb=c287bea94592fffe63f85831ab651c28d64e4d6e;hp=46e818591180942f63ba03179a45f31fadd24c6d;hpb=6e93da5e0a775b2bfb9c9f2bd31a36cc828521cb;p=ghc-hetmet.git

diff --git a/utils/ext-core/Core.hs b/utils/ext-core/Core.hs
index 46e8185..9df300e 100644
--- a/utils/ext-core/Core.hs
+++ b/utils/ext-core/Core.hs
@@ -1,25 +1,34 @@
 module Core where
 
+import Encoding
+
+import Data.Generics
 import List (elemIndex)
 
 data Module 
  = Module AnMname [Tdef] [Vdefg]
+  deriving (Data, Typeable)
 
 data Tdef 
   = Data (Qual Tcon) [Tbind] [Cdef]
-  | Newtype (Qual Tcon) [Tbind] Axiom (Maybe Ty)
+    -- type constructor; coercion name; type arguments; type rep
+    -- If we have: (Newtype tc co tbs (Just t))
+    -- there is an implicit axiom:
+    --  co tbs :: tc tbs :=: t
+  | Newtype (Qual Tcon) (Qual Tcon) [Tbind] (Maybe Ty)
+ deriving (Data, Typeable)
 
 data Cdef 
   = Constr (Qual Dcon) [Tbind] [Ty]
-
--- Newtype coercion
-type Axiom = (Qual Tcon, Kind)
+  deriving (Data, Typeable)
 
 data Vdefg 
   = Rec [Vdef]
   | Nonrec Vdef
+  deriving (Data, Typeable)
 
 newtype Vdef = Vdef (Qual Var,Ty,Exp)
+  deriving (Data, Typeable)
 
 data Exp 
   = Var (Qual Var)
@@ -33,15 +42,18 @@ data Exp
   | Cast Exp Ty
   | Note String Exp
   | External String Ty
+  deriving (Data, Typeable)
 
 data Bind 
   = Vb Vbind
   | Tb Tbind
+  deriving (Data, Typeable)
 
 data Alt 
   = Acon (Qual Dcon) [Tbind] [Vbind] Exp
   | Alit Lit Exp
   | Adefault Exp
+  deriving (Data, Typeable)
 
 type Vbind = (Var,Ty)
 type Tbind = (Tvar,Kind)
@@ -51,6 +63,17 @@ data Ty
   | Tcon (Qual Tcon)
   | Tapp Ty Ty
   | Tforall Tbind Ty 
+-- Wired-in coercions:
+-- These are primitive tycons in GHC, but in ext-core,
+-- we make them explicit, to make the typechecker
+-- somewhat more clear. 
+  | TransCoercion Ty Ty
+  | SymCoercion Ty
+  | UnsafeCoercion Ty Ty
+  | InstCoercion Ty Ty
+  | LeftCoercion Ty
+  | RightCoercion Ty
+  deriving (Data, Typeable)
 
 data Kind 
   = Klifted
@@ -58,15 +81,35 @@ data Kind
   | Kopen
   | Karrow Kind Kind
   | Keq Ty Ty
-
+  deriving (Data, Typeable)
+
+-- A CoercionKind isn't really a Kind at all, but rather,
+-- corresponds to an arbitrary user-declared axiom.
+-- A tycon whose CoercionKind is (DefinedCoercion <tbs> (from, to))
+-- represents a tycon with arity (length tbs), whose kind is
+-- (from :=: to) (modulo substituting type arguments.
+-- It's not a Kind because a coercion must always be fully applied:
+-- whenever we see a tycon that has such a CoercionKind, it must
+-- be fully applied if it's to be assigned an actual Kind.
+-- So, a CoercionKind *only* appears in the environment (mapping
+-- newtype axioms onto CoercionKinds).
+-- Was that clear??
+data CoercionKind = 
+   DefinedCoercion [Tbind] (Ty,Ty)
+
+-- The type constructor environment maps names that are
+-- either type constructors or coercion names onto either
+-- kinds or coercion kinds.
+data KindOrCoercion = Kind Kind | Coercion CoercionKind
+  
 data Lit = Literal CoreLit Ty
-  deriving Eq   -- with nearlyEqualTy 
+  deriving (Data, Typeable, Eq)   -- with nearlyEqualTy 
 
 data CoreLit = Lint Integer
   | Lrational Rational
   | Lchar Char
   | Lstring String 
-  deriving Eq
+  deriving (Data, Typeable, Eq)
 
 -- Right now we represent module names as triples:
 -- (package name, hierarchical names, leaf name)
@@ -74,12 +117,14 @@ data CoreLit = Lint Integer
 -- module namespace, either when printing out
 -- Core or (probably preferably) in a 
 -- preprocessor.
--- The empty module name (as in an unqualified name)
--- is represented as Nothing.
+-- We represent the empty module name (as in an unqualified name)
+-- with Nothing.
 
 type Mname = Maybe AnMname
-type AnMname = (Pname, [Id], Id)
-type Pname = Id
+newtype AnMname = M (Pname, [Id], Id)
+  deriving (Eq, Ord, Data, Typeable)
+newtype Pname = P Id
+  deriving (Eq, Ord, Data, Typeable)
 type Var = Id
 type Tvar = Id
 type Tcon = Id
@@ -93,6 +138,9 @@ qual mn t = (Just mn, t)
 unqual :: t -> Qual t
 unqual = (,) Nothing
 
+getModule :: Qual t -> Mname
+getModule = fst
+
 type Id = String
 
 eqKind :: Kind -> Kind -> Bool
@@ -101,11 +149,21 @@ eqKind Kunlifted Kunlifted = True
 eqKind Kopen Kopen = True
 eqKind (Karrow k1 k2) (Karrow l1 l2) = k1 `eqKind` l1
                                    &&  k2 `eqKind` l2
-eqKind _ _ = False -- no Keq kind is ever equal to any other...
-                   -- maybe ok for now?
-
---- tjc: I haven't looked at the rest of this file. ---
-
+eqKind (Keq t1 t2) (Keq u1 u2) = t1 == u1
+                              && t2 == u2
+eqKind _ _ = False
+
+splitTyConApp_maybe :: Ty -> Maybe (Qual Tcon,[Ty])
+splitTyConApp_maybe (Tvar _) = Nothing
+splitTyConApp_maybe (Tcon t) = Just (t,[])
+splitTyConApp_maybe (Tapp rator rand) = 
+   case (splitTyConApp_maybe rator) of
+      Just (r,rs) -> Just (r,rs++[rand])
+      Nothing     -> case rator of
+                       Tcon tc -> Just (tc,[rand])
+                       _       -> Nothing
+splitTyConApp_maybe t@(Tforall _ _) = Nothing
+           
 {- Doesn't expand out fully applied newtype synonyms
    (for which an environment is needed). -}
 nearlyEqualTy t1 t2 =  eqTy [] [] t1 t2 
@@ -125,6 +183,8 @@ instance Eq Ty where (==) = nearlyEqualTy
 
 subKindOf :: Kind -> Kind -> Bool
 _ `subKindOf` Kopen = True
+(Karrow a1 r1) `subKindOf` (Karrow a2 r2) = 
+  a2 `subKindOf` a1 && (r1 `subKindOf` r2)
 k1 `subKindOf` k2 = k1 `eqKind` k2  -- doesn't worry about higher kinds
 
 baseKind :: Kind -> Bool
@@ -134,17 +194,28 @@ baseKind _ = True
 isPrimVar (Just mn,_) = mn == primMname
 isPrimVar _ = False
 
-primMname = mkBaseMname "Prim"
+primMname = mkPrimMname "Prim"
 errMname  = mkBaseMname "Err"
-mkBaseMname :: Id -> AnMname
-mkBaseMname mn = (basePkg, ghcPrefix, mn)
-basePkg = "base"
-mainPkg = "main"
+mkBaseMname,mkPrimMname :: Id -> AnMname
+mkBaseMname mn = M (basePkg, ghcPrefix, mn)
+mkPrimMname mn = M (primPkg, ghcPrefix, mn)
+basePkg = P "base"
+mainPkg = P "main"
+primPkg = P $ zEncodeString "ghc-prim"
 ghcPrefix = ["GHC"]
 mainPrefix = []
 baseMname = mkBaseMname "Base"
+boolMname = mkPrimMname "Bool"
 mainVar = qual mainMname "main"
-mainMname = (mainPkg, mainPrefix, "Main")
+wrapperMainVar = qual wrapperMainMname "main"
+mainMname = M (mainPkg, mainPrefix, "Main")
+wrapperMainMname = M (mainPkg, mainPrefix, "ZCMain")
+wrapperMainAnMname = Just wrapperMainMname
+
+dcTrue :: Dcon
+dcTrue = "True"
+dcFalse :: Dcon
+dcFalse = "False"
 
 tcArrow :: Qual Tcon
 tcArrow = (Just primMname, "ZLzmzgZR")
@@ -152,14 +223,15 @@ tcArrow = (Just primMname, "ZLzmzgZR")
 tArrow :: Ty -> Ty -> Ty
 tArrow t1 t2 = Tapp (Tapp (Tcon tcArrow) t1) t2
 
+mkFunTy :: Ty -> Ty -> Ty
+mkFunTy randTy resultTy =
+  Tapp (Tapp (Tcon tcArrow) randTy) resultTy
 
 ktArrow :: Kind
 ktArrow = Karrow Kopen (Karrow Kopen Klifted)
 
 {- Unboxed tuples -}
 
--- tjc: not sure whether anything that follows is right
-
 maxUtuple :: Int
 maxUtuple = 100
 
@@ -178,7 +250,9 @@ isUtupleTy (Tcon tc) = tc `elem` [tcUtuple n | n <- [1..maxUtuple]]
 isUtupleTy _ = False
 
 dcUtuple :: Int -> Qual Dcon
-dcUtuple n = (Just primMname,"ZdwZ" ++ (show n) ++ "H")
+-- TODO: Seems like Z2H etc. appears in ext-core files,
+-- not $wZ2H etc. Is this right?
+dcUtuple n = (Just primMname,"Z" ++ (show n) ++ "H")
 
 isUtupleDc :: Qual Dcon -> Bool
 isUtupleDc dc = dc `elem` [dcUtuple n | n <- [1..maxUtuple]]
@@ -194,4 +268,8 @@ dcUtupleTy n =
 utuple :: [Ty] -> [Exp] -> Exp
 utuple ts es = foldl App (foldl Appt (Dcon (dcUtuple (length es))) ts) es
 
-
+---- snarfed from GHC's CoreSyn
+flattenBinds :: [Vdefg] -> [Vdef]	-- Get all the lhs/rhs pairs
+flattenBinds (Nonrec vd : binds) = vd : flattenBinds binds
+flattenBinds (Rec prs1   : binds) = prs1 ++ flattenBinds binds
+flattenBinds []			  = []