ghc/compiler/abstractSyn/HsCore.lhs

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