ghc/compiler/coreSyn/CoreSyn.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[CoreSyn]{A data type for the Haskell compiler midsection}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module CoreSyn (
  10         GenCoreBinding(..), GenCoreExpr(..), GenCoreAtom(..),
  11         GenCoreCaseAlternatives(..), GenCoreCaseDefault(..),
  12         pprCoreBinding, pprCoreExpr,
  13
  14         GenCoreArg(..), applyToArgs, decomposeArgs, collectArgs,
  15
  16         -- and to make the interface self-sufficient ...
  17     ) where
  18
  19 import PrelInfo         ( PrimOp, PrimRep
  20                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  21                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  22                         )
  23 import Type             ( isPrimType, pprParendUniType, TyVar, TyCon, Type
  24                         )
  25 import Literal          ( Literal )
  26 import Id               ( getIdUniType, isBottomingId, Id
  27                           IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
  28                         )
  29 import Outputable
  30 import Pretty
  31 import CostCentre       ( showCostCentre, CostCentre )
  32 import Util
  33 \end{code}
  34
  35 %************************************************************************
  36 %*                                                                      *
  37 \subsection[CoreTopBinding_and_CoreBinding]{@CoreTopBinding@ and @GenCoreBinding@}
  38 %*                                                                      *
  39 %************************************************************************
  40
  41 Core programs, bindings, expressions, etc., are parameterised with
  42 respect to the information kept about binding and bound occurrences of
  43 variables, called {\em binders} and {\em val_occ tyvar uvars}, respectively.  [I
  44 don't really like the pair of names; I prefer {\em binder} and {\em
  45 bounder}.  Or {\em binder} and {\em var}.]
  46
  47 A @GenCoreBinding@ is either a single non-recursive binding of a
  48 ``binder'' to an expression, or a mutually-recursive blob of same.
  49 \begin{code}
  50 data GenCoreBinding val_bdr val_occ tyvar uvar
  51   = NonRec      val_bdr (GenCoreExpr val_bdr val_occ tyvar uvar)
  52   | Rec         [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)]
  53 \end{code}
  54
  55
  56 %************************************************************************
  57 %*                                                                      *
  58 \subsection[GenCoreExpr]{Core expressions: @GenCoreExpr@}
  59 %*                                                                      *
  60 %************************************************************************
  61
  62 @GenCoreExpr@ is the heart of the ``core'' data types; it is
  63 (more-or-less) boiled-down second-order polymorphic lambda calculus.
  64 For types in the core world, we just keep using @Types@.
  65 \begin{code}
  66 data GenCoreExpr val_bdr val_occ tyvar uvar
  67      = Var    val_occ
  68      | Lit    Literal   -- literal constants
  69 \end{code}
  70
  71 @Cons@ and @Prims@ are saturated constructor and primitive-op
  72 applications (see the comment).  Note: @Con@s are only set up by the
  73 simplifier (and by the desugarer when it knows what it's doing).  The
  74 desugarer sets up constructors as applications of global @Vars@s.
  75
  76 \begin{code}
  77      | Con      Id (GenType tyvar) [GenCoreArg val_occ tyvar uvar]
  78                 -- Saturated constructor application:
  79                 -- The constructor is a function of the form:
  80                 --      /\ a1 -> ... /\ am -> \ b1 -> ... \ bn ->
  81                 -- <expr> where "/\" is a type lambda and "\" the
  82                 -- regular kind; there will be "m" Types and
  83                 -- "n" bindees in the Con args.
  84                 --
  85                 -- The type given is the result type of the application;
  86                 -- you can figure out the argument types from it if you want.
  87
  88      | Prim     PrimOp Type [GenCoreArg val_occ tyvar uvar]
  89                 -- saturated primitive operation;
  90                 -- comment on Cons applies here, too.
  91                 -- The types work the same way
  92                 -- (PrimitiveOps may be polymorphic).
  93 \end{code}
  94
  95 Ye olde abstraction and application operators.
  96 \begin{code}
  97      | Lam      (GenCoreBinder val_bdr tyvar uvar)
  98                 (GenCoreExpr val_bdr val_occ tyvar uvar)
  99
 100      | App      (GenCoreExpr val_bdr val_occ tyvar uvar)
 101                 (GenCoreArg val_occ tyvar uvar)
 102 \end{code}
 103
 104 Case expressions (\tr{case <expr> of <List of alternatives>}): there
 105 are really two flavours masquerading here---those for scrutinising
 106 {\em algebraic} types and those for {\em primitive} types.  Please see
 107 under @GenCoreCaseAlternatives@.
 108 \begin{code}
 109      | Case     (GenCoreExpr val_bdr val_occ tyvar uvar)
 110                 (GenCoreCaseAlternatives val_bdr val_occ tyvar uvar)
 111 \end{code}
 112
 113 A Core case expression \tr{case e of v -> ...} implies evaluation of
 114 \tr{e}; it is not equivalent to \tr{let v = in ...} (as with a Haskell
 115 \tr{case}).
 116
 117 Non-recursive @Lets@ only have one binding; having more than one
 118 doesn't buy you much, and it is an easy way to mess up variable
 119 scoping.
 120 \begin{code}
 121      | Let      (GenCoreBinding val_bdr val_occ tyvar uvar)
 122                 (GenCoreExpr binder val_occ tyvar uvar)
 123                 -- both recursive and non-.
 124                 -- The "GenCoreBinding" records that information
 125 \end{code}
 126
 127 For cost centre scc expressions we introduce a new core construct
 128 @SCC@ so transforming passes have to deal with it explicitly. The
 129 alternative of using a new PrimativeOp may result in a bad
 130 transformations of which we are unaware.
 131 \begin{code}
 132      | SCC      CostCentre                                  -- label of scc
 133                 (GenCoreExpr val_bdr val_occ tyvar uvar)    -- scc expression
 134 \end{code}
 135
 136
 137 %************************************************************************
 138 %*                                                                      *
 139 \subsection{Case alternatives in @GenCoreExpr@}
 140 %*                                                                      *
 141 %************************************************************************
 142
 143 We have different kinds of @case@s, the differences being reflected in
 144 the kinds of alternatives a case has.  We maintain a distinction
 145 between cases for scrutinising algebraic datatypes, as opposed to
 146 primitive types.  In both cases, we carry around a @TyCon@, as a
 147 handle with which we can get info about the case (e.g., total number
 148 of data constructors for this type).
 149
 150 For example:
 151 \begin{verbatim}
 152 let# x=e in b
 153 \end{verbatim}
 154 becomes
 155 \begin{verbatim}
 156 Case e [ BindDefaultAlt x -> b ]
 157 \end{verbatim}
 158
 159 \begin{code}
 160 data GenCoreCaseAlternatives val_bdr val_occ tyvar uvar
 161
 162   = AlgAlts     [(Id,                           -- alts: data constructor,
 163                   [val_bdr],                    -- constructor's parameters,
 164                   GenCoreExpr val_bdr val_occ tyvar uvar)]      -- rhs.
 165                 (GenCoreCaseDefault val_bdr val_occ tyvar uvar)
 166
 167   | PrimAlts    [(Literal,                      -- alts: unboxed literal,
 168                   GenCoreExpr val_bdr val_occ tyvar uvar)]      -- rhs.
 169                 (GenCoreCaseDefault val_bdr val_occ tyvar uvar)
 170
 171 -- obvious things: if there are no alts in the list, then the default
 172 -- can't be NoDefault.
 173
 174 data GenCoreCaseDefault val_bdr val_occ tyvar uvar
 175   = NoDefault                                   -- small con family: all
 176                                                 -- constructor accounted for
 177   | BindDefault val_bdr                         -- form: var -> expr;
 178                 (GenCoreExpr val_bdr val_occ tyvar uvar)        -- "val_bdr" may or may not
 179                                                 -- be used in RHS.
 180 \end{code}
 181
 182 %************************************************************************
 183 %*                                                                      *
 184 \subsection[CoreSyn-arguments]{Core ``argument'' wrapper type}
 185 %*                                                                      *
 186 %************************************************************************
 187
 188 \begin{code}
 189 data GenCoreAtom val_occ tyvar uvar
 190   = LitAtom     Literal
 191   | VarAtom     val_occ
 192   | TyAtom      (GenType tyvar)
 193   | UsageAtom   (Usage uvar)
 194
 195
 196 ===+*** fix from here down ****===
 197 =================================
 198
 199 instance Outputable bindee => Outputable (GenCoreArg bindee) where
 200   ppr sty (ValArg atom) = ppr sty atom
 201   ppr sty (TypeArg ty)  = ppr sty ty
 202 \end{code}
 203
 204 \begin{code}
 205 applyToArgs :: GenCoreExpr val_bdr bindee
 206             -> [GenCoreArg bindee]
 207             -> GenCoreExpr val_bdr bindee
 208
 209 applyToArgs fun []                  = fun
 210 applyToArgs fun (ValArg val : args) = applyToArgs (App  fun val) args
 211 applyToArgs fun (TypeArg ty : args) = applyToArgs (CoTyApp fun ty) args
 212 \end{code}
 213
 214 @decomposeArgs@ just pulls of the contiguous TypeArg-then-ValArg block
 215 on the front of the args.  Pretty common.
 216
 217 \begin{code}
 218 decomposeArgs :: [GenCoreArg bindee]
 219               -> ([Type], [GenCoreAtom bindee], [GenCoreArg bindee])
 220
 221 decomposeArgs [] = ([],[],[])
 222
 223 decomposeArgs (TypeArg ty : args)
 224   = case (decomposeArgs args) of { (tys, vals, rest) ->
 225     (ty:tys, vals, rest) }
 226
 227 decomposeArgs (ValArg val : args)
 228   = case (do_vals args) of { (vals, rest) ->
 229     ([], val:vals, rest) }
 230   where
 231     do_vals (ValArg val : args)
 232       = case (do_vals args) of { (vals, rest) ->
 233         (val:vals, rest) }
 234
 235     do_vals args = ([], args)
 236 \end{code}
 237
 238 @collectArgs@ takes an application expression, returning the function
 239 and the arguments to which it is applied.
 240
 241 \begin{code}
 242 collectArgs :: GenCoreExpr val_bdr bindee
 243             -> (GenCoreExpr val_bdr bindee, [GenCoreArg bindee])
 244
 245 collectArgs expr
 246   = collect expr []
 247   where
 248     collect (App fun arg)  args = collect fun (ValArg arg : args)
 249     collect (CoTyApp fun ty) args = collect fun (TypeArg ty : args)
 250     collect other_expr args       = (other_expr, args)
 251 \end{code}
 252
 253 %************************************************************************
 254 %*                                                                      *
 255 \subsection[CoreSyn-output]{Instance declarations for output}
 256 %*                                                                      *
 257 %************************************************************************
 258
 259 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
 260 function for ``major'' val_bdrs (those next to equal signs :-),
 261 ``minor'' ones (lambda-bound, case-bound), and bindees.  They would
 262 usually be called through some intermediary.
 263
 264 \begin{code}
 265 pprCoreBinding
 266         :: PprStyle
 267         -> (PprStyle -> bndr -> Pretty) -- to print "major" val_bdrs
 268         -> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs
 269         -> (PprStyle -> bdee -> Pretty) -- to print bindees
 270         -> GenCoreBinding bndr bdee
 271         -> Pretty
 272
 273 pprCoreBinding sty pbdr1 pbdr2 pbdee (NonRec val_bdr expr)
 274   = ppHang (ppCat [pbdr1 sty val_bdr, ppEquals])
 275          4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
 276
 277 pprCoreBinding sty pbdr1 pbdr2 pbdee (Rec binds)
 278   = ppAboves [ifPprDebug sty (ppStr "{- Rec -}"),
 279               ppAboves (map ppr_bind binds),
 280               ifPprDebug sty (ppStr "{- end Rec -}")]
 281   where
 282     ppr_bind (val_bdr, expr)
 283       = ppHang (ppCat [pbdr1 sty val_bdr, ppEquals])
 284              4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
 285 \end{code}
 286
 287 \begin{code}
 288 instance (Outputable bndr, Outputable bdee)
 289                 => Outputable (GenCoreBinding bndr bdee) where
 290     ppr sty bind = pprCoreBinding sty ppr ppr ppr bind
 291
 292 instance (Outputable bndr, Outputable bdee)
 293                 => Outputable (GenCoreExpr bndr bdee) where
 294     ppr sty expr = pprCoreExpr sty ppr ppr ppr expr
 295
 296 instance Outputable bdee => Outputable (GenCoreAtom bdee) where
 297     ppr sty atom = pprCoreAtom sty ppr atom
 298 \end{code}
 299
 300 \begin{code}
 301 pprCoreAtom
 302         :: PprStyle
 303         -> (PprStyle -> bdee -> Pretty) -- to print bindees
 304         -> GenCoreAtom bdee
 305         -> Pretty
 306
 307 pprCoreAtom sty pbdee (LitAtom lit) = ppr sty lit
 308 pprCoreAtom sty pbdee (VarAtom v)   = pbdee sty v
 309 \end{code}
 310
 311 \begin{code}
 312 pprCoreExpr, pprParendCoreExpr
 313         :: PprStyle
 314         -> (PprStyle -> bndr -> Pretty) -- to print "major" val_bdrs
 315         -> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs
 316         -> (PprStyle -> bdee -> Pretty) -- to print bindees
 317         -> GenCoreExpr bndr bdee
 318         -> Pretty
 319
 320 pprCoreExpr sty pbdr1 pbdr2 pbdee (Var name) = pbdee sty name
 321
 322 pprCoreExpr sty pbdr1 pbdr2 pbdee (Lit literal) = ppr sty literal
 323
 324 pprCoreExpr sty pbdr1 pbdr2 pbdee (Con con [] []) = ppr sty con
 325
 326 pprCoreExpr sty pbdr1 pbdr2 pbdee (Con con types args)
 327   = ppHang (ppBesides [ppr sty con, ppChar '!'])
 328          4 (ppSep (  (map (pprParendUniType sty) types)
 329                   ++ (map (pprCoreAtom sty pbdee) args)))
 330
 331 pprCoreExpr sty pbdr1 pbdr2 pbdee (Prim prim tys args)
 332   = ppHang (ppBesides [ppr sty prim, ppChar '!'])
 333          4 (ppSep (  (map (pprParendUniType sty) tys)
 334                   ++ (map (pprCoreAtom sty pbdee) args) ))
 335
 336 pprCoreExpr sty pbdr1 pbdr2 pbdee (Lam val_bdr expr)
 337   = ppHang (ppCat [ppStr "\\", pbdr2 sty val_bdr, ppStr "->"])
 338          4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
 339
 340 pprCoreExpr sty pbdr1 pbdr2 pbdee (CoTyLam tyvar expr)
 341   = ppHang (ppCat [ppStr "/\\", interppSP sty (tyvar:tyvars),
 342                    ppStr "->", pp_varss var_lists])
 343            4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr_after)
 344   where
 345     (tyvars, var_lists, expr_after) = collect_tyvars expr
 346
 347     collect_tyvars (CoTyLam tyv e) = ( tyv:tyvs, vs, e_after )
 348       where (tyvs, vs, e_after) = collect_tyvars e
 349     collect_tyvars e@(Lam _ _)   = ( [], vss, e_after )
 350       where (vss, e_after) = collect_vars e
 351     collect_tyvars other_e         = ( [], [], other_e )
 352
 353     collect_vars (Lam var e) = ([var]:varss, e_after)
 354       where (varss, e_after) = collect_vars e
 355     collect_vars other_e           = ( [], other_e )
 356
 357     pp_varss [] = ppNil
 358     pp_varss (vars:varss)
 359       = ppCat [ppStr "\\", ppInterleave ppSP (map (pbdr2 sty) vars),
 360                ppStr "->", pp_varss varss]
 361
 362 pprCoreExpr sty pbdr1 pbdr2 pbdee expr@(App fun_expr atom)
 363   = let
 364         (fun, args) = collect_args expr []
 365     in
 366     ppHang (pprParendCoreExpr sty pbdr1 pbdr2 pbdee fun)
 367          4 (ppSep (map (pprCoreAtom sty pbdee) args))
 368   where
 369     collect_args (App fun arg) args = collect_args fun (arg:args)
 370     collect_args fun             args = (fun, args)
 371
 372 pprCoreExpr sty pbdr1 pbdr2 pbdee (CoTyApp expr ty)
 373   = ppHang (ppBeside pp_note (pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr))
 374          4 (pprParendUniType sty ty)
 375   where
 376     pp_note = ifPprShowAll sty (ppStr "{-CoTyApp-} ")
 377
 378 pprCoreExpr sty pbdr1 pbdr2 pbdee (Case expr alts)
 379   = ppSep [ppSep [ppStr "case", ppNest 4 (pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr),
 380                      ppStr "of {"],
 381            ppNest 2 (pprCoreCaseAlts sty pbdr1 pbdr2 pbdee alts),
 382            ppStr "}"]
 383
 384 -- special cases: let ... in let ...
 385 -- ("disgusting" SLPJ)
 386
 387 pprCoreExpr sty pbdr1 pbdr2 pbdee (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
 388   = ppAboves [
 389       ppCat [ppStr "let {", pbdr1 sty val_bdr, ppEquals],
 390       ppNest 2 (pprCoreExpr sty pbdr1 pbdr2 pbdee rhs),
 391       ppStr "} in",
 392       pprCoreExpr sty pbdr1 pbdr2 pbdee body ]
 393
 394 pprCoreExpr sty pbdr1 pbdr2 pbdee (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
 395   = ppAbove
 396       (ppHang (ppStr "let {")
 397             2 (ppCat [ppHang (ppCat [pbdr1 sty val_bdr, ppEquals])
 398                            4 (pprCoreExpr sty pbdr1 pbdr2 pbdee rhs),
 399        ppStr "} in"]))
 400       (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
 401
 402 -- general case (recursive case, too)
 403 pprCoreExpr sty pbdr1 pbdr2 pbdee (Let bind expr)
 404   = ppSep [ppHang (ppStr "let {") 2 (pprCoreBinding sty pbdr1 pbdr2 pbdee bind),
 405            ppHang (ppStr "} in ") 2 (pprCoreExpr    sty pbdr1 pbdr2 pbdee expr)]
 406
 407 pprCoreExpr sty pbdr1 pbdr2 pbdee (SCC cc expr)
 408   = ppSep [ ppCat [ppStr "_scc_", ppStr (showCostCentre sty True{-as string-} cc)],
 409             pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr ]
 410 \end{code}
 411
 412 \begin{code}
 413 pprParendCoreExpr sty pbdr1 pbdr2 pbdee e@(Var _) = pprCoreExpr sty pbdr1 pbdr2 pbdee e
 414 pprParendCoreExpr sty pbdr1 pbdr2 pbdee e@(Lit _) = pprCoreExpr sty pbdr1 pbdr2 pbdee e
 415 pprParendCoreExpr sty pbdr1 pbdr2 pbdee other_e
 416   = ppBesides [ppLparen, pprCoreExpr sty pbdr1 pbdr2 pbdee other_e, ppRparen]
 417 \end{code}
 418
 419 \begin{code}
 420 instance (Outputable bndr, Outputable bdee)
 421                 => Outputable (GenCoreCaseAlternatives bndr bdee) where
 422     ppr sty alts = pprCoreCaseAlts sty ppr ppr ppr alts
 423 \end{code}
 424
 425 \begin{code}
 426 pprCoreCaseAlts
 427         :: PprStyle
 428         -> (PprStyle -> bndr -> Pretty) -- to print "major" val_bdrs
 429         -> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs
 430         -> (PprStyle -> bdee -> Pretty) -- to print bindees
 431         -> GenCoreCaseAlternatives bndr bdee
 432         -> Pretty
 433
 434 pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (AlgAlts alts deflt)
 435   = ppAboves [ ppAboves (map ppr_alt alts),
 436                pprCoreCaseDefault sty pbdr1 pbdr2 pbdee deflt ]
 437   where
 438     ppr_alt (con, params, expr)
 439       = ppHang (ppCat [ppr_con con,
 440                        ppInterleave ppSP (map (pbdr2 sty) params),
 441                        ppStr "->"])
 442                 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
 443       where
 444         ppr_con con
 445           = if isOpLexeme con
 446             then ppBesides [ppLparen, ppr sty con, ppRparen]
 447             else ppr sty con
 448
 449 pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (PrimAlts alts deflt)
 450   = ppAboves [ ppAboves (map ppr_alt alts),
 451                pprCoreCaseDefault sty pbdr1 pbdr2 pbdee deflt ]
 452   where
 453     ppr_alt (lit, expr)
 454       = ppHang (ppCat [ppr sty lit, ppStr "->"])
 455              4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
 456 \end{code}
 457
 458 \begin{code}
 459 instance (Outputable bndr, Outputable bdee)
 460                 => Outputable (GenCoreCaseDefault bndr bdee) where
 461     ppr sty deflt  = pprCoreCaseDefault sty ppr ppr ppr deflt
 462 \end{code}
 463
 464 \begin{code}
 465 pprCoreCaseDefault
 466         :: PprStyle
 467         -> (PprStyle -> bndr -> Pretty) -- to print "major" val_bdrs
 468         -> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs
 469         -> (PprStyle -> bdee -> Pretty) -- to print bindees
 470         -> GenCoreCaseDefault bndr bdee
 471         -> Pretty
 472
 473 pprCoreCaseDefault sty pbdr1 pbdr2 pbdee NoDefault = ppNil
 474
 475 pprCoreCaseDefault sty pbdr1 pbdr2 pbdee (BindDefault val_bdr expr)
 476   = ppHang (ppCat [pbdr2 sty val_bdr, ppStr "->"])
 477          4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
 478 \end{code}