ghc/compiler/deSugar/DsExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[DsExpr]{Matching expressions (Exprs)}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module DsExpr ( dsExpr ) where
  10
  11 import Ubiq
  12 import DsLoop           -- partly to get dsBinds, partly to chk dsExpr
  13
  14 import HsSyn            ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
  15                           Match, Qual, HsBinds, Stmt, PolyType )
  16 import TcHsSyn          ( TypecheckedHsExpr(..), TypecheckedHsBinds(..) )
  17 import CoreSyn
  18
  19 import DsMonad
  20 import DsCCall          ( dsCCall )
  21 import DsListComp       ( dsListComp )
  22 import DsUtils          ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom )
  23 import Match            ( matchWrapper )
  24
  25 import CoreUnfold       ( UnfoldingDetails(..), UnfoldingGuidance(..),
  26                           FormSummary )
  27 import CoreUtils        ( coreExprType, substCoreExpr, argToExpr,
  28                           mkCoreIfThenElse, unTagBinders )
  29 import CostCentre       ( mkUserCC )
  30 import Id               ( mkTupleCon, idType, nullIdEnv, addOneToIdEnv,
  31                           getIdUnfolding )
  32 import Literal          ( mkMachInt, Literal(..) )
  33 import MagicUFs         ( MagicUnfoldingFun )
  34 import PprStyle         ( PprStyle(..) )
  35 import PprType          ( GenType, GenTyVar )
  36 import PrelInfo         ( mkTupleTy, unitTy, nilDataCon, consDataCon,
  37                           charDataCon, charTy )
  38 import Pretty           ( ppShow )
  39 import Type             ( splitSigmaTy )
  40 import TyVar            ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar )
  41 import Unique           ( Unique )
  42 import Usage            ( UVar(..) )
  43 import Util             ( panic )
  44
  45 primRepFromType = panic "DsExpr.primRepFromType"
  46 maybeBoxedPrimType = panic "DsExpr.maybeBoxedPrimType"
  47 splitTyArgs = panic "DsExpr.splitTyArgs"
  48
  49 mk_nil_con ty = mkCon nilDataCon [] [ty] []  -- micro utility...
  50 \end{code}
  51
  52 The funny business to do with variables is that we look them up in the
  53 Id-to-Id and Id-to-Id maps that the monadery is carrying
  54 around; if we get hits, we use the value accordingly.
  55
  56 %************************************************************************
  57 %*                                                                      *
  58 \subsection[DsExpr-vars-and-cons]{Variables and constructors}
  59 %*                                                                      *
  60 %************************************************************************
  61
  62 \begin{code}
  63 dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
  64
  65 dsExpr (HsVar var) = dsApp (HsVar var) []
  66 \end{code}
  67
  68 %************************************************************************
  69 %*                                                                      *
  70 \subsection[DsExpr-literals]{Literals}
  71 %*                                                                      *
  72 %************************************************************************
  73
  74 We give int/float literals type Integer and Rational, respectively.
  75 The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
  76 around them.
  77
  78 ToDo: put in range checks for when converting "i"
  79 (or should that be in the typechecker?)
  80
  81 For numeric literals, we try to detect there use at a standard type
  82 (Int, Float, etc.) are directly put in the right constructor.
  83 [NB: down with the @App@ conversion.]
  84 Otherwise, we punt, putting in a "NoRep" Core literal (where the
  85 representation decisions are delayed)...
  86
  87 See also below where we look for @DictApps@ for \tr{plusInt}, etc.
  88
  89 \begin{code}
  90 dsExpr (HsLitOut (HsString s) _)
  91   | _NULL_ s
  92   = returnDs (mk_nil_con charTy)
  93
  94   | _LENGTH_ s == 1
  95   = let
  96         the_char = mkCon charDataCon [] [] [LitArg (MachChar (_HEAD_ s))]
  97         the_nil  = mk_nil_con charTy
  98     in
  99     mkConDs consDataCon [charTy] [the_char, the_nil]
 100
 101 -- "_" => build (\ c n -> c 'c' n)      -- LATER
 102
 103 -- "str" ==> build (\ c n -> foldr charTy T c n "str")
 104
 105 {- LATER:
 106 dsExpr (HsLitOut (HsString str) _) =
 107     newTyVarsDs [alphaTyVar]            `thenDs` \ [new_tyvar] ->
 108     let
 109         new_ty = mkTyVarTy new_tyvar
 110     in
 111     newSysLocalsDs [
 112                 charTy `mkFunTy` (new_ty `mkFunTy` new_ty),
 113                 new_ty,
 114                        mkForallTy [alphaTyVar]
 115                                ((charTy `mkFunTy` (alphaTy `mkFunTy` alphaTy))
 116                                         `mkFunTy` (alphaTy `mkFunTy` alphaTy))
 117                 ]                       `thenDs` \ [c,n,g] ->
 118      returnDs (mkBuild charTy new_tyvar c n g (
 119         foldl App
 120           (CoTyApp (CoTyApp (Var foldrId) charTy) new_ty) *** ensure non-prim type ***
 121           [VarArg c,VarArg n,LitArg (NoRepStr str)]))
 122 -}
 123
 124 -- otherwise, leave it as a NoRepStr;
 125 -- the Core-to-STG pass will wrap it in an application of "unpackCStringId".
 126
 127 dsExpr (HsLitOut (HsString str) _)
 128   = returnDs (Lit (NoRepStr str))
 129
 130 dsExpr (HsLitOut (HsLitLit s) ty)
 131   = returnDs ( mkCon data_con [] [] [LitArg (MachLitLit s kind)] )
 132   where
 133     (data_con, kind)
 134       = case (maybeBoxedPrimType ty) of
 135           Nothing
 136             -> error ("ERROR: ``literal-literal'' not a single-constructor type: "++ _UNPK_ s ++"; type: "++(ppShow 80 (ppr PprDebug ty)))
 137           Just (boxing_data_con, prim_ty)
 138             -> (boxing_data_con, primRepFromType prim_ty)
 139
 140 dsExpr (HsLitOut (HsInt i) _)
 141   = returnDs (Lit (NoRepInteger i))
 142
 143 dsExpr (HsLitOut (HsFrac r) _)
 144   = returnDs (Lit (NoRepRational r))
 145
 146 -- others where we know what to do:
 147
 148 dsExpr (HsLitOut (HsIntPrim i) _)
 149   = if (i >= toInteger minInt && i <= toInteger maxInt) then
 150         returnDs (Lit (mkMachInt i))
 151     else
 152         error ("ERROR: Int constant " ++ show i ++ out_of_range_msg)
 153
 154 dsExpr (HsLitOut (HsFloatPrim f) _)
 155   = returnDs (Lit (MachFloat f))
 156     -- ToDo: range checking needed!
 157
 158 dsExpr (HsLitOut (HsDoublePrim d) _)
 159   = returnDs (Lit (MachDouble d))
 160     -- ToDo: range checking needed!
 161
 162 dsExpr (HsLitOut (HsChar c) _)
 163   = returnDs ( mkCon charDataCon [] [] [LitArg (MachChar c)] )
 164
 165 dsExpr (HsLitOut (HsCharPrim c) _)
 166   = returnDs (Lit (MachChar c))
 167
 168 dsExpr (HsLitOut (HsStringPrim s) _)
 169   = returnDs (Lit (MachStr s))
 170
 171 -- end of literals magic. --
 172
 173 dsExpr expr@(HsLam a_Match)
 174   = let
 175         error_msg = "%L" --> "pattern-matching failed in lambda"
 176     in
 177     matchWrapper LambdaMatch [a_Match] error_msg `thenDs` \ (binders, matching_code) ->
 178     returnDs ( mkValLam binders matching_code )
 179
 180 dsExpr expr@(HsApp e1 e2)    = dsApp expr []
 181 dsExpr expr@(OpApp e1 op e2) = dsApp expr []
 182 \end{code}
 183
 184 Operator sections.  At first it looks as if we can convert
 185 \begin{verbatim}
 186         (expr op)
 187 \end{verbatim}
 188 to
 189 \begin{verbatim}
 190         \x -> op expr x
 191 \end{verbatim}
 192
 193 But no!  expr might be a redex, and we can lose laziness badly this
 194 way.  Consider
 195 \begin{verbatim}
 196         map (expr op) xs
 197 \end{verbatim}
 198 for example.  So we convert instead to
 199 \begin{verbatim}
 200         let y = expr in \x -> op y x
 201 \end{verbatim}
 202 If \tr{expr} is actually just a variable, say, then the simplifier
 203 will sort it out.
 204
 205 \begin{code}
 206 dsExpr (SectionL expr op)
 207   = dsExpr op                   `thenDs` \ core_op ->
 208     dsExpr expr                 `thenDs` \ core_expr ->
 209     dsExprToAtom core_expr      $ \ y_atom ->
 210
 211     -- for the type of x, we need the type of op's 2nd argument
 212     let
 213         x_ty  = case (splitSigmaTy (coreExprType core_op)) of { (_, _, tau_ty) ->
 214                 case (splitTyArgs tau_ty)                 of {
 215                   ((_:arg2_ty:_), _) -> arg2_ty;
 216                   _ -> panic "dsExpr:SectionL:arg 2 ty"
 217                 }}
 218     in
 219     newSysLocalDs x_ty          `thenDs` \ x_id ->
 220     returnDs (mkValLam [x_id] (core_op `App` y_atom `App` VarArg x_id))
 221
 222 -- dsExpr (SectionR op expr)    -- \ x -> op x expr
 223 dsExpr (SectionR op expr)
 224   = dsExpr op                   `thenDs` \ core_op ->
 225     dsExpr expr                 `thenDs` \ core_expr ->
 226     dsExprToAtom core_expr      $ \ y_atom ->
 227
 228     -- for the type of x, we need the type of op's 1st argument
 229     let
 230         x_ty  = case (splitSigmaTy (coreExprType core_op)) of { (_, _, tau_ty) ->
 231                 case (splitTyArgs tau_ty)                 of {
 232                   ((arg1_ty:_), _) -> arg1_ty;
 233                   _ -> panic "dsExpr:SectionR:arg 1 ty"
 234                 }}
 235     in
 236     newSysLocalDs x_ty          `thenDs` \ x_id ->
 237     returnDs (mkValLam [x_id] (core_op `App` VarArg x_id `App` y_atom))
 238
 239 dsExpr (CCall label args may_gc is_asm result_ty)
 240   = mapDs dsExpr args           `thenDs` \ core_args ->
 241     dsCCall label core_args may_gc is_asm result_ty
 242         -- dsCCall does all the unboxification, etc.
 243
 244 dsExpr (HsSCC cc expr)
 245   = dsExpr expr                 `thenDs` \ core_expr ->
 246     getModuleAndGroupDs         `thenDs` \ (mod_name, group_name) ->
 247     returnDs ( SCC (mkUserCC cc mod_name group_name) core_expr)
 248
 249 dsExpr expr@(HsCase discrim matches src_loc)
 250   = putSrcLocDs src_loc $
 251     dsExpr discrim              `thenDs` \ core_discrim ->
 252     let
 253         error_msg = "%C" --> "pattern-matching failed in case"
 254     in
 255     matchWrapper CaseMatch matches error_msg `thenDs` \ ([discrim_var], matching_code) ->
 256     returnDs ( mkCoLetAny (NonRec discrim_var core_discrim) matching_code )
 257
 258 dsExpr (ListComp expr quals)
 259   = dsExpr expr `thenDs` \ core_expr ->
 260     dsListComp core_expr quals
 261
 262 dsExpr (HsLet binds expr)
 263   = dsBinds binds       `thenDs` \ core_binds ->
 264     dsExpr expr         `thenDs` \ core_expr ->
 265     returnDs ( mkCoLetsAny core_binds core_expr )
 266
 267 dsExpr (HsDoOut stmts m_id mz_id src_loc)
 268   = putSrcLocDs src_loc $
 269     panic "dsExpr:HsDoOut"
 270
 271 dsExpr (ExplicitListOut ty xs)
 272   = case xs of
 273       []     -> returnDs (mk_nil_con ty)
 274       (y:ys) ->
 275         dsExpr y                            `thenDs` \ core_hd  ->
 276         dsExpr (ExplicitListOut ty ys)  `thenDs` \ core_tl  ->
 277         mkConDs consDataCon [ty] [core_hd, core_tl]
 278
 279 dsExpr (ExplicitTuple expr_list)
 280   = mapDs dsExpr expr_list        `thenDs` \ core_exprs  ->
 281     mkConDs (mkTupleCon (length expr_list))
 282             (map coreExprType core_exprs)
 283             core_exprs
 284
 285 dsExpr (RecordCon con  rbinds) = panic "dsExpr:RecordCon"
 286 dsExpr (RecordUpd aexp rbinds) = panic "dsExpr:RecordUpd"
 287
 288 dsExpr (HsIf guard_expr then_expr else_expr src_loc)
 289   = putSrcLocDs src_loc $
 290     dsExpr guard_expr   `thenDs` \ core_guard ->
 291     dsExpr then_expr    `thenDs` \ core_then ->
 292     dsExpr else_expr    `thenDs` \ core_else ->
 293     returnDs (mkCoreIfThenElse core_guard core_then core_else)
 294
 295 dsExpr (ArithSeqOut expr (From from))
 296   = dsExpr expr           `thenDs` \ expr2 ->
 297     dsExpr from           `thenDs` \ from2 ->
 298     mkAppDs expr2 [] [from2]
 299
 300 dsExpr (ArithSeqOut expr (FromTo from two))
 301   = dsExpr expr           `thenDs` \ expr2 ->
 302     dsExpr from           `thenDs` \ from2 ->
 303     dsExpr two            `thenDs` \ two2 ->
 304     mkAppDs expr2 [] [from2, two2]
 305
 306 dsExpr (ArithSeqOut expr (FromThen from thn))
 307   = dsExpr expr           `thenDs` \ expr2 ->
 308     dsExpr from           `thenDs` \ from2 ->
 309     dsExpr thn            `thenDs` \ thn2 ->
 310     mkAppDs expr2 [] [from2, thn2]
 311
 312 dsExpr (ArithSeqOut expr (FromThenTo from thn two))
 313   = dsExpr expr           `thenDs` \ expr2 ->
 314     dsExpr from           `thenDs` \ from2 ->
 315     dsExpr thn            `thenDs` \ thn2 ->
 316     dsExpr two            `thenDs` \ two2 ->
 317     mkAppDs expr2 [] [from2, thn2, two2]
 318 \end{code}
 319
 320 \begin{code}
 321 dsExpr (TyLam tyvars expr)
 322   = dsExpr expr `thenDs` \ core_expr ->
 323     returnDs (mkTyLam tyvars core_expr)
 324
 325 dsExpr expr@(TyApp e tys) = dsApp expr []
 326 \end{code}
 327
 328 @DictLam@ and @DictApp@ turn into the regular old things.
 329 (OLD:) @DictFunApp@ also becomes a curried application, albeit slightly more
 330 complicated; reminiscent of fully-applied constructors.
 331 \begin{code}
 332 dsExpr (DictLam dictvars expr)
 333   = dsExpr expr `thenDs` \ core_expr ->
 334     returnDs( mkValLam dictvars core_expr )
 335
 336 ------------------
 337
 338 dsExpr expr@(DictApp e dicts)   -- becomes a curried application
 339   = dsApp expr []
 340 \end{code}
 341
 342 @SingleDicts@ become @Locals@; @Dicts@ turn into tuples, unless
 343 of length 0 or 1.
 344 @ClassDictLam dictvars methods expr@ is ``the opposite'':
 345 \begin{verbatim}
 346 \ x -> case x of ( dictvars-and-methods-tuple ) -> expr
 347 \end{verbatim}
 348 \begin{code}
 349 dsExpr (SingleDict dict)        -- just a local
 350   = lookupEnvWithDefaultDs dict (Var dict)
 351
 352 dsExpr (Dictionary dicts methods)
 353   = -- hey, these things may have been substituted away...
 354     zipWithDs lookupEnvWithDefaultDs
 355               dicts_and_methods dicts_and_methods_exprs
 356                         `thenDs` \ core_d_and_ms ->
 357
 358     (case num_of_d_and_ms of
 359       0 -> returnDs cocon_unit -- unit
 360
 361       1 -> returnDs (head core_d_and_ms) -- just a single Id
 362
 363       _ ->          -- tuple 'em up
 364            mkConDs (mkTupleCon num_of_d_and_ms)
 365                    (map coreExprType core_d_and_ms)
 366                    core_d_and_ms
 367     )
 368   where
 369     dicts_and_methods       = dicts ++ methods
 370     dicts_and_methods_exprs = map Var dicts_and_methods
 371     num_of_d_and_ms         = length dicts_and_methods
 372
 373 dsExpr (ClassDictLam dicts methods expr)
 374   = dsExpr expr         `thenDs` \ core_expr ->
 375     case num_of_d_and_ms of
 376         0 -> newSysLocalDs unitTy `thenDs` \ new_x ->
 377              returnDs (mkValLam [new_x] core_expr)
 378
 379         1 -> -- no untupling
 380             returnDs (mkValLam dicts_and_methods core_expr)
 381
 382         _ ->                            -- untuple it
 383             newSysLocalDs tuple_ty `thenDs` \ new_x ->
 384             returnDs (
 385               Lam (ValBinder new_x)
 386                 (Case (Var new_x)
 387                     (AlgAlts
 388                         [(tuple_con, dicts_and_methods, core_expr)]
 389                         NoDefault)))
 390   where
 391     num_of_d_and_ms         = length dicts + length methods
 392     dicts_and_methods       = dicts ++ methods
 393     tuple_ty                = mkTupleTy    num_of_d_and_ms (map idType dicts_and_methods)
 394     tuple_con               = mkTupleCon   num_of_d_and_ms
 395
 396 #ifdef DEBUG
 397 -- HsSyn constructs that just shouldn't be here:
 398 dsExpr (HsDo _ _)           = panic "dsExpr:HsDo"
 399 dsExpr (ExplicitList _)     = panic "dsExpr:ExplicitList"
 400 dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"
 401 dsExpr (ArithSeqIn _)       = panic "dsExpr:ArithSeqIn"
 402 #endif
 403
 404 cocon_unit = mkCon (mkTupleCon 0) [] [] [] -- out here to avoid CAF (sigh)
 405 out_of_range_msg                           -- ditto
 406   = " out of range: [" ++ show minInt ++ ", " ++ show maxInt ++ "]\n"
 407 \end{code}
 408
 409 %--------------------------------------------------------------------
 410
 411 @(dsApp e [t_1,..,t_n, e_1,..,e_n])@ returns something with the same
 412 value as:
 413 \begin{verbatim}
 414 e t_1 ... t_n  e_1 .. e_n
 415 \end{verbatim}
 416
 417 We're doing all this so we can saturate constructors (as painlessly as
 418 possible).
 419
 420 \begin{code}
 421 type DsCoreArg = GenCoreArg CoreExpr{-NB!-} TyVar UVar
 422
 423 dsApp :: TypecheckedHsExpr      -- expr to desugar
 424       -> [DsCoreArg]            -- accumulated ty/val args: NB:
 425       -> DsM CoreExpr   -- final result
 426
 427 dsApp (HsApp e1 e2) args
 428   = dsExpr e2                   `thenDs` \ core_e2 ->
 429     dsApp  e1 (VarArg core_e2 : args)
 430
 431 dsApp (OpApp e1 op e2) args
 432   = dsExpr e1                   `thenDs` \ core_e1 ->
 433     dsExpr e2                   `thenDs` \ core_e2 ->
 434     dsApp  op (VarArg core_e1 : VarArg core_e2 : args)
 435
 436 dsApp (DictApp expr dicts) args
 437   =     -- now, those dicts may have been substituted away...
 438     zipWithDs lookupEnvWithDefaultDs dicts (map Var dicts)
 439                                 `thenDs` \ core_dicts ->
 440     dsApp expr (map VarArg core_dicts ++ args)
 441
 442 dsApp (TyApp expr tys) args
 443   = dsApp expr (map TyArg tys ++ args)
 444
 445 -- we might should look out for SectionLs, etc., here, but we don't
 446
 447 dsApp (HsVar v) args
 448   = lookupEnvDs v       `thenDs` \ maybe_expr ->
 449     case maybe_expr of
 450       Just expr -> apply_to_args expr args
 451
 452       Nothing -> -- we're only saturating constructors and PrimOps
 453         case getIdUnfolding v of
 454           GenForm _ _ the_unfolding EssentialUnfolding
 455             -> do_unfold nullTyVarEnv nullIdEnv (unTagBinders the_unfolding) args
 456
 457           _ -> apply_to_args (Var v) args
 458
 459
 460 dsApp anything_else args
 461   = dsExpr anything_else        `thenDs` \ core_expr ->
 462     apply_to_args core_expr args
 463
 464 -- a DsM version of mkGenApp:
 465 apply_to_args :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr
 466
 467 apply_to_args fun args
 468   = let
 469         (ty_args, val_args) = foldr sep ([],[]) args
 470     in
 471     mkAppDs fun ty_args val_args
 472   where
 473     sep a@(LitArg l)   (tys,vals) = (tys,    (Lit l):vals)
 474     sep a@(VarArg e)   (tys,vals) = (tys,    e:vals)
 475     sep a@(TyArg ty)   (tys,vals) = (ty:tys, vals)
 476     sep a@(UsageArg _) _          = panic "DsExpr:apply_to_args:UsageArg"
 477 \end{code}
 478
 479 \begin{code}
 480 do_unfold ty_env val_env (Lam (TyBinder tyvar) body) (TyArg ty : args)
 481   = do_unfold (addOneToTyVarEnv ty_env tyvar ty) val_env body args
 482
 483 do_unfold ty_env val_env (Lam (ValBinder binder) body) (VarArg expr : args)
 484   = dsExprToAtom expr  $ \ arg_atom ->
 485     do_unfold ty_env
 486               (addOneToIdEnv val_env binder (argToExpr arg_atom))
 487               body args
 488
 489 do_unfold ty_env val_env body args
 490   =     -- Clone the remaining part of the template
 491     uniqSMtoDsM (substCoreExpr val_env ty_env body)     `thenDs` \ body' ->
 492
 493         -- Apply result to remaining arguments
 494     apply_to_args body' args
 495 \end{code}