ghc/compiler/hsSyn/HsCore.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[HsCore]{Core-syntax unfoldings in Haskell interface files}
   7 %*                                                                      *
   8 %************************************************************************
   9
  10 We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
  11 @TyVars@ as well.  Currently trying the former.
  12
  13 \begin{code}
  14 #include "HsVersions.h"
  15
  16 module HsCore (
  17         -- types:
  18         UnfoldingCoreExpr(..), UnfoldingCoreAlts(..),
  19         UnfoldingCoreDefault(..), UnfoldingCoreBinding(..),
  20         UnfoldingCoreAtom(..), UfId(..), UnfoldingType(..),
  21         UnfoldingPrimOp(..), UfCostCentre(..),
  22
  23         -- function:
  24         eqUfExpr
  25     ) where
  26
  27 import Ubiq{-uitous-}
  28
  29 -- friends:
  30 import HsTypes          ( cmpPolyType, MonoType(..), PolyType(..) )
  31 import PrimOp           ( PrimOp, tagOf_PrimOp )
  32
  33 -- others:
  34 import Literal          ( Literal )
  35 import Outputable       ( Outputable(..) {-instances-} )
  36 import Pretty
  37 import ProtoName        ( cmpProtoName, eqProtoName, ProtoName )
  38 import Util             ( panic )
  39 \end{code}
  40
  41 %************************************************************************
  42 %*                                                                      *
  43 \subsection[HsCore-types]{Types for read/written Core unfoldings}
  44 %*                                                                      *
  45 %************************************************************************
  46
  47 \begin{code}
  48 data UnfoldingCoreExpr name
  49   = UfVar       (UfId name)
  50   | UfLit       Literal
  51   | UfCon       name -- must be a "BoringUfId"...
  52                 [UnfoldingType name]
  53                 [UnfoldingCoreAtom name]
  54   | UfPrim      (UnfoldingPrimOp name)
  55                 [UnfoldingType name]
  56                 [UnfoldingCoreAtom name]
  57   | UfLam       (UfBinder name)
  58                 (UnfoldingCoreExpr name)
  59   | UfApp       (UnfoldingCoreExpr name)
  60                 (UnfoldingCoreAtom name)
  61   | UfCase      (UnfoldingCoreExpr name)
  62                 (UnfoldingCoreAlts name)
  63   | UfLet       (UnfoldingCoreBinding name)
  64                 (UnfoldingCoreExpr name)
  65   | UfSCC       (UfCostCentre name)
  66                 (UnfoldingCoreExpr name)
  67
  68 data UnfoldingPrimOp name
  69   = UfCCallOp   FAST_STRING          -- callee
  70                 Bool                 -- True <=> casm, rather than ccall
  71                 Bool                 -- True <=> might cause GC
  72                 [UnfoldingType name] -- arg types, incl state token
  73                                      -- (which will be first)
  74                 (UnfoldingType name) -- return type
  75   | UfOtherOp   PrimOp
  76
  77 data UnfoldingCoreAlts name
  78   = UfCoAlgAlts  [(name, [UfBinder name], UnfoldingCoreExpr name)]
  79                  (UnfoldingCoreDefault name)
  80   | UfCoPrimAlts [(Literal, UnfoldingCoreExpr name)]
  81                  (UnfoldingCoreDefault name)
  82
  83 data UnfoldingCoreDefault name
  84   = UfCoNoDefault
  85   | UfCoBindDefault (UfBinder name)
  86                     (UnfoldingCoreExpr name)
  87
  88 data UnfoldingCoreBinding name
  89   = UfCoNonRec  (UfBinder name)
  90                 (UnfoldingCoreExpr name)
  91   | UfCoRec     [(UfBinder name, UnfoldingCoreExpr name)]
  92
  93 data UnfoldingCoreAtom name
  94   = UfCoVarAtom (UfId name)
  95   | UfCoLitAtom Literal
  96
  97 data UfCostCentre name
  98   = UfPreludeDictsCC
  99                 Bool    -- True <=> is dupd
 100   | UfAllDictsCC FAST_STRING    -- module and group
 101                 FAST_STRING
 102                 Bool    -- True <=> is dupd
 103   | UfUserCC    FAST_STRING
 104                 FAST_STRING FAST_STRING -- module and group
 105                 Bool    -- True <=> is dupd
 106                 Bool    -- True <=> is CAF
 107   | UfAutoCC    (UfId name)
 108                 FAST_STRING FAST_STRING -- module and group
 109                 Bool Bool -- as above
 110   | UfDictCC    (UfId name)
 111                 FAST_STRING FAST_STRING -- module and group
 112                 Bool Bool -- as above
 113
 114 type UfBinder name = (name, UnfoldingType name)
 115
 116 data UfId name
 117   = BoringUfId          name
 118   | SuperDictSelUfId    name name       -- class and superclass
 119   | ClassOpUfId         name name       -- class and class op
 120   | DictFunUfId         name            -- class and type
 121                         (UnfoldingType name)
 122   | ConstMethodUfId     name name       -- class, class op, and type
 123                         (UnfoldingType name)
 124   | DefaultMethodUfId   name name       -- class and class op
 125   | SpecUfId            (UfId name)     -- its unspecialised "parent"
 126                         [Maybe (MonoType name)]
 127   | WorkerUfId          (UfId name)     -- its non-working "parent"
 128   -- more to come?
 129
 130 type UnfoldingType name = PolyType name
 131 \end{code}
 132
 133 %************************************************************************
 134 %*                                                                      *
 135 \subsection[HsCore-print]{Printing Core unfoldings}
 136 %*                                                                      *
 137 %************************************************************************
 138
 139 \begin{code}
 140 instance Outputable name => Outputable (UnfoldingCoreExpr name) where
 141     ppr sty (UfVar v) = pprUfId sty v
 142     ppr sty (UfLit l) = ppr sty l
 143
 144     ppr sty (UfCon c tys as)
 145       = ppCat [ppStr "(UfCon", ppr sty c, ppr sty tys, ppr sty as, ppStr ")"]
 146     ppr sty (UfPrim o tys as)
 147       = ppCat [ppStr "(UfPrim", ppr sty o, ppr sty tys, ppr sty as, ppStr ")"]
 148
 149     ppr sty (UfLam bs body)
 150       = ppCat [ppChar '\\', ppr sty bs, ppStr "->", ppr sty body]
 151
 152     ppr sty (UfApp fun arg)
 153       = ppCat [ppStr "(UfApp", ppr sty fun, ppr sty arg, ppStr ")"]
 154
 155     ppr sty (UfCase scrut alts)
 156       = ppCat [ppStr "case", ppr sty scrut, ppStr "of {", pp_alts alts, ppStr "}"]
 157       where
 158         pp_alts (UfCoAlgAlts alts deflt)
 159           = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
 160           where
 161            pp_alt (c,bs,rhs) = ppCat [ppr sty c, ppr sty bs, ppStr "->", ppr sty rhs]
 162         pp_alts (UfCoPrimAlts alts deflt)
 163           = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
 164           where
 165            pp_alt (l,rhs) = ppCat [ppr sty l, ppStr "->", ppr sty rhs]
 166
 167         pp_deflt UfCoNoDefault = ppNil
 168         pp_deflt (UfCoBindDefault b rhs) = ppCat [ppr sty b, ppStr "->", ppr sty rhs]
 169
 170     ppr sty (UfLet (UfCoNonRec b rhs) body)
 171       = ppCat [ppStr "let", ppr sty b, ppEquals, ppr sty rhs, ppStr "in", ppr sty body]
 172     ppr sty (UfLet (UfCoRec pairs) body)
 173       = ppCat [ppStr "letrec {", ppInterleave ppSemi (map pp_pair pairs), ppStr "} in", ppr sty body]
 174       where
 175         pp_pair (b,rhs) = ppCat [ppr sty b, ppEquals, ppr sty rhs]
 176
 177     ppr sty (UfSCC uf_cc body)
 178       = ppCat [ppStr "_scc_ <cost-centre[ToDo]>", ppr sty body]
 179
 180 instance Outputable name => Outputable (UnfoldingPrimOp name) where
 181     ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty)
 182       = let
 183             before = ppStr (if is_casm then "_casm_ ``" else "_ccall_ ")
 184             after  = if is_casm then ppStr "'' " else ppSP
 185         in
 186         ppBesides [before, ppPStr str, after,
 187                 ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty]
 188     ppr sty (UfOtherOp op)
 189       = ppr sty op
 190
 191 instance Outputable name => Outputable (UnfoldingCoreAtom name) where
 192     ppr sty (UfCoVarAtom v) = pprUfId sty v
 193     ppr sty (UfCoLitAtom l)         = ppr sty l
 194
 195 pprUfId sty (BoringUfId v) = ppr sty v
 196 pprUfId sty (SuperDictSelUfId c sc)
 197   = ppBesides [ppStr "({-superdict-}", ppr sty c, ppSP, ppr sty sc, ppStr ")"]
 198 pprUfId sty (ClassOpUfId c op)
 199   = ppBesides [ppStr "({-method-}", ppr sty c, ppSP, ppr sty op, ppStr ")"]
 200 pprUfId sty (DictFunUfId c ty)
 201   = ppBesides [ppStr "({-dfun-}", ppr sty c, ppSP, ppr sty ty, ppStr ")"]
 202 pprUfId sty (ConstMethodUfId c op ty)
 203   = ppBesides [ppStr "({-constm-}", ppr sty c, ppSP, ppr sty op, ppSP, ppr sty ty, ppStr ")"]
 204 pprUfId sty (DefaultMethodUfId c ty)
 205   = ppBesides [ppStr "({-defm-}", ppr sty c, ppSP, ppr sty ty, ppStr ")"]
 206
 207 pprUfId sty (SpecUfId unspec ty_maybes)
 208   = ppBesides [ppStr "({-spec-} ", pprUfId sty unspec,
 209                 ppInterleave ppSP (map pp_ty_maybe ty_maybes), ppStr ")"]
 210   where
 211     pp_ty_maybe Nothing  = ppStr "_N_"
 212     pp_ty_maybe (Just t) = ppr sty t
 213
 214 pprUfId sty (WorkerUfId unwrkr)
 215   = ppBesides [ppStr "({-wrkr-}", pprUfId sty unwrkr, ppStr ")"]
 216 \end{code}
 217
 218 %************************************************************************
 219 %*                                                                      *
 220 \subsection[HsCore-equality]{Comparing Core unfoldings}
 221 %*                                                                      *
 222 %************************************************************************
 223
 224 We want to check that they are {\em exactly} the same.
 225
 226 \begin{code}
 227 --eqUfExpr :: ProtoNameCoreExpr -> ProtoNameCoreExpr -> Bool
 228
 229 eqUfExpr (UfVar v1)     (UfVar v2)     = eqUfId v1 v2
 230 eqUfExpr (UfLit l1) (UfLit l2) = l1 == l2
 231
 232 eqUfExpr (UfCon c1 tys1 as1) (UfCon c2 tys2 as2)
 233   = eq_name c1 c2 && eq_lists eq_type tys1 tys2 && eq_lists eq_atom as1 as2
 234 eqUfExpr (UfPrim o1 tys1 as1) (UfPrim o2 tys2 as2)
 235   = eq_op o1 o2 && eq_lists eq_type tys1 tys2 && eq_lists eq_atom as1 as2
 236   where
 237     eq_op (UfCCallOp _ _ _ _ _) (UfCCallOp _ _ _ _ _) = True
 238     eq_op (UfOtherOp o1)        (UfOtherOp o2)
 239       = tagOf_PrimOp o1 _EQ_ tagOf_PrimOp o2
 240
 241 eqUfExpr (UfLam bs1 body1) (UfLam bs2 body2)
 242   = eq_binder bs1 bs2 && eqUfExpr body1 body2
 243
 244 eqUfExpr (UfApp fun1 arg1) (UfApp fun2 arg2)
 245   = eqUfExpr fun1 fun2 && eq_atom arg1 arg2
 246
 247 eqUfExpr (UfCase scrut1 alts1) (UfCase scrut2 alts2)
 248   = eqUfExpr scrut1 scrut2 && eq_alts alts1 alts2
 249   where
 250     eq_alts (UfCoAlgAlts alts1 deflt1) (UfCoAlgAlts alts2 deflt2)
 251       = eq_lists eq_alt alts1 alts2 && eq_deflt deflt1 deflt2
 252       where
 253        eq_alt (c1,bs1,rhs1) (c2,bs2,rhs2)
 254          = eq_name c1 c2 && eq_lists eq_binder bs1 bs2 && eqUfExpr rhs1 rhs2
 255
 256     eq_alts (UfCoPrimAlts alts1 deflt1) (UfCoPrimAlts alts2 deflt2)
 257       = eq_lists eq_alt alts1 alts2 && eq_deflt deflt1 deflt2
 258       where
 259        eq_alt (l1,rhs1) (l2,rhs2)
 260          = l1 == l2 && eqUfExpr rhs1 rhs2
 261
 262     eq_alts _ _ = False -- catch-all
 263
 264     eq_deflt UfCoNoDefault UfCoNoDefault = True
 265     eq_deflt (UfCoBindDefault b1 rhs1) (UfCoBindDefault b2 rhs2)
 266       = eq_binder b1 b2 && eqUfExpr rhs1 rhs2
 267     eq_deflt _ _ = False
 268
 269 eqUfExpr (UfLet (UfCoNonRec b1 rhs1) body1) (UfLet (UfCoNonRec b2 rhs2) body2)
 270   = eq_binder b1 b2 && eqUfExpr rhs1 rhs2 && eqUfExpr body1 body2
 271
 272 eqUfExpr (UfLet (UfCoRec pairs1) body1) (UfLet (UfCoRec pairs2) body2)
 273   = eq_lists eq_pair pairs1 pairs2 && eqUfExpr body1 body2
 274   where
 275     eq_pair (b1,rhs1) (b2,rhs2) = eq_binder b1 b2 && eqUfExpr rhs1 rhs2
 276
 277 eqUfExpr (UfSCC cc1 body1) (UfSCC cc2 body2)
 278   = {-trace "eqUfExpr: not comparing cost-centres!"-} (eqUfExpr body1 body2)
 279
 280 eqUfExpr _ _ = False -- Catch-all
 281 \end{code}
 282
 283 \begin{code}
 284 eqUfId (BoringUfId n1) (BoringUfId n2)
 285   = eq_name n1 n2
 286 eqUfId (SuperDictSelUfId a1 b1) (SuperDictSelUfId a2 b2)
 287   = eq_name a1 a2 && eq_name b1 b2
 288 eqUfId (ClassOpUfId a1 b1) (ClassOpUfId a2 b2)
 289   = eq_name a1 a2 && eq_name b1 b2
 290 eqUfId (DictFunUfId c1 t1) (DictFunUfId c2 t2)
 291   = eq_name c1 c2 && eq_tycon t1 t2 -- NB: **** only compare TyCons ******
 292   where
 293     eq_tycon = panic "HsCore:eqUfId:eq_tycon:ToDo"
 294 {- LATER:
 295     eq_tycon (UnoverloadedTy ty1) (UnoverloadedTy ty2)
 296       = case (cmpInstanceTypes ty1 ty2) of { EQ_ -> True; _ -> False }
 297     eq_tycon ty1 ty2
 298       = trace "eq_tycon" (eq_type ty1 ty2) -- desperately try something else
 299 -}
 300
 301 eqUfId (ConstMethodUfId a1 b1 t1) (ConstMethodUfId a2 b2 t2)
 302   = eq_name a1 a2 && eq_name b1 b2 && eq_type t1 t2
 303 eqUfId (DefaultMethodUfId a1 b1) (DefaultMethodUfId a2 b2)
 304   = eq_name a1 a2 && eq_name b1 b2
 305 eqUfId (SpecUfId id1 tms1) (SpecUfId id2 tms2)
 306   = eqUfId id1 id2 && eq_lists eq_ty_maybe tms1 tms2
 307   where
 308     eq_ty_maybe = panic "HsCore:eqUfId:eq_ty_maybe:ToDo"
 309 {-
 310     eq_ty_maybe Nothing Nothing = True
 311     eq_ty_maybe (Just ty1) (Just ty2)
 312       = eq_type (UnoverloadedTy ty1) (UnoverloadedTy ty2)
 313       -- a HACKy way to compare MonoTypes (ToDo) [WDP 94/05/02]
 314     eq_ty_maybe _ _ = False
 315 -}
 316 eqUfId (WorkerUfId id1) (WorkerUfId id2)
 317   = eqUfId id1 id2
 318 eqUfId _ _ = False -- catch-all
 319 \end{code}
 320
 321 \begin{code}
 322 eq_atom (UfCoVarAtom id1) (UfCoVarAtom id2) = eqUfId id1 id2
 323 eq_atom (UfCoLitAtom l1) (UfCoLitAtom l2) = l1 == l2
 324 eq_atom _ _ = False
 325
 326 eq_binder (n1, ty1) (n2, ty2) = eq_name n1 n2 && eq_type ty1 ty2
 327
 328 eq_name :: ProtoName -> ProtoName -> Bool
 329 eq_name pn1 pn2 = eqProtoName pn1 pn2 -- uses original names
 330
 331 eq_type ty1 ty2
 332   = case (cmpPolyType cmpProtoName ty1 ty2) of { EQ_ -> True; _ -> False }
 333 \end{code}
 334
 335 \begin{code}
 336 eq_lists :: (a -> a -> Bool) -> [a] -> [a] -> Bool
 337
 338 eq_lists eq [] [] = True
 339 eq_lists eq [] _  = False
 340 eq_lists eq _  [] = False
 341 eq_lists eq (x:xs) (y:ys) = eq x y && eq_lists eq xs ys
 342 \end{code}