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