ghc/compiler/deSugar/DsExpr.lhs

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