ghc/compiler/deSugar/DsBinds.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[DsBinds]{Pattern-matching bindings (HsBinds and MonoBinds)}
   5
   6 Handles @HsBinds@; those at the top level require different handling,
   7 in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
   8 lower levels it is preserved with @let@/@letrec@s).
   9
  10 \begin{code}
  11 #include "HsVersions.h"
  12
  13 module DsBinds ( dsBinds ) where
  14
  15 IMP_Ubiq()
  16 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
  17 IMPORT_DELOOPER(DsLoop)         -- break dsExpr-ish loop
  18 #else
  19 import {-# SOURCE #-} DsExpr
  20 #endif
  21
  22 import HsSyn            -- lots of things
  23 import CoreSyn          -- lots of things
  24 import CoreUtils        ( coreExprType )
  25 import TcHsSyn          ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
  26                           SYN_IE(TypecheckedMonoBinds),
  27                           SYN_IE(TypecheckedPat)
  28                         )
  29 import DsMonad
  30 import DsGRHSs          ( dsGuarded )
  31 import DsUtils
  32 import Match            ( matchWrapper )
  33
  34 import BasicTypes       ( SYN_IE(Module) )
  35 import CmdLineOpts      ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs,
  36                           opt_AutoSccsOnExportedToplevs, opt_CompilingGhcInternals )
  37 import CostCentre       ( mkAutoCC, IsCafCC(..), mkAllDictsCC, preludeDictsCostCentre )
  38 import Id               ( idType, SYN_IE(DictVar), GenId, SYN_IE(Id) )
  39 import ListSetOps       ( minusList, intersectLists )
  40 import Name             ( isExported )
  41 import PprType          ( GenType )
  42 import Outputable       ( PprStyle(..) )
  43 import Type             ( mkTyVarTy, isDictTy, instantiateTy
  44                         )
  45 import TyVar            ( tyVarSetToList, GenTyVar{-instance Eq-} )
  46 import TysPrim          ( voidTy )
  47 import Util             ( isIn, panic, assertPanic  )
  48 \end{code}
  49
  50 %************************************************************************
  51 %*                                                                      *
  52 \subsection[toplevel-and-regular-DsBinds]{Regular and top-level @dsBinds@}
  53 %*                                                                      *
  54 %************************************************************************
  55
  56 Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be
  57 that some of the binders are of unboxed type.  This is sorted out when
  58 the caller wraps the bindings round an expression.
  59
  60 \begin{code}
  61 type Group = FAST_STRING
  62
  63 dsBinds :: Maybe (Module, Group) -> TypecheckedHsBinds -> DsM [CoreBinding]
  64
  65 dsBinds _ EmptyBinds                 = returnDs []
  66 dsBinds mb_mod_grp (ThenBinds binds_1 binds_2)
  67   = andDs (++) (dsBinds mb_mod_grp binds_1) (dsBinds mb_mod_grp binds_2)
  68
  69 dsBinds mb_mod_grp (MonoBind binds sigs is_rec)
  70   = dsMonoBinds mb_mod_grp is_rec binds  `thenDs` \ prs ->
  71     returnDs (if is_rec then
  72                 [Rec prs]
  73               else
  74                 [NonRec binder rhs | (binder,rhs) <- prs]
  75     )
  76 \end{code}
  77
  78
  79 %************************************************************************
  80 %*                                                                      *
  81 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
  82 %*                                                                      *
  83 %************************************************************************
  84
  85 \begin{code}
  86 dsMonoBinds :: Maybe (Module, Group)   -- Nothing => don't (auto-)annotate scc on toplevs.
  87             -> RecFlag
  88             -> TypecheckedMonoBinds
  89             -> DsM [(Id,CoreExpr)]
  90
  91 dsMonoBinds _ is_rec EmptyMonoBinds = returnDs []
  92
  93 dsMonoBinds mb_mod_grp is_rec (AndMonoBinds  binds_1 binds_2)
  94   = andDs (++) (dsMonoBinds mb_mod_grp is_rec binds_1) (dsMonoBinds mb_mod_grp is_rec binds_2)
  95
  96 dsMonoBinds _ is_rec (CoreMonoBind var core_expr)
  97   = returnDs [(var, core_expr)]
  98
  99 dsMonoBinds _ is_rec (VarMonoBind var expr)
 100   = dsExpr expr                 `thenDs` \ core_expr ->
 101
 102         -- Dictionary bindings are always VarMonoBinds, so
 103         -- we only need do this here
 104     addDictScc var core_expr    `thenDs` \ core_expr' ->
 105
 106     returnDs [(var, core_expr')]
 107
 108 dsMonoBinds mb_mod_grp is_rec (FunMonoBind fun _ matches locn)
 109   = putSrcLocDs locn    $
 110     matchWrapper (FunMatch fun) matches error_string    `thenDs` \ (args, body) ->
 111     returnDs [addAutoScc mb_mod_grp (fun, mkValLam args body)]
 112   where
 113     error_string = "function " ++ showForErr fun
 114
 115 dsMonoBinds mb_mod_grp is_rec (PatMonoBind pat grhss_and_binds locn)
 116   = putSrcLocDs locn $
 117     dsGuarded grhss_and_binds           `thenDs` \ body_expr ->
 118     mkSelectorBinds pat body_expr
 119
 120         -- Common special case: no type or dictionary abstraction
 121 dsMonoBinds mb_mod_grp is_rec (AbsBinds [] [] exports binds)
 122   = dsMonoBinds Nothing is_rec binds                    `thenDs` \ prs ->
 123     returnDs (prs ++ [ addAutoScc mb_mod_grp (global, Var local) | (_, global, local) <- exports])
 124
 125         -- Another common case: one exported variable
 126         -- All non-recursive bindings come through this way
 127 dsMonoBinds mb_mod_grp is_rec (AbsBinds all_tyvars dicts [(tyvars, global, local)] binds)
 128   = ASSERT( all (`elem` tyvars) all_tyvars )
 129     dsMonoBinds Nothing is_rec binds                    `thenDs` \ core_prs ->
 130     let
 131         core_binds | is_rec    = [Rec core_prs]
 132                    | otherwise = [NonRec b e | (b,e) <- core_prs]
 133     in
 134     returnDs [addAutoScc mb_mod_grp (global, mkLam tyvars dicts $
 135                                              mkCoLetsAny core_binds (Var local))]
 136
 137 dsMonoBinds mb_mod_grp is_rec (AbsBinds all_tyvars dicts exports binds)
 138   = dsMonoBinds Nothing is_rec binds                    `thenDs` \ core_prs ->
 139     let
 140         core_binds | is_rec    = [Rec core_prs]
 141                    | otherwise = [NonRec b e | (b,e) <- core_prs]
 142
 143         tup_expr = mkLam all_tyvars dicts $
 144                    mkCoLetsAny core_binds $
 145                    mkTupleExpr locals
 146         locals    = [local | (_, _, local) <- exports]
 147         local_tys = map idType locals
 148     in
 149     newSysLocalDs (coreExprType tup_expr)               `thenDs` \ tup_id ->
 150     let
 151         dict_args    = map VarArg dicts
 152
 153         mk_bind (tyvars, global, local) n       -- locals !! n == local
 154           =     -- Need to make fresh locals to bind in the selector, because
 155                 -- some of the tyvars will be bound to voidTy
 156             newSysLocalsDs (map (instantiateTy env) local_tys)  `thenDs` \ locals' ->
 157             returnDs (addAutoScc mb_mod_grp $
 158                         (global, mkLam tyvars dicts $
 159                                  mkTupleSelector locals' (locals' !! n) $
 160                                  mkValApp (mkTyApp (Var tup_id) ty_args) dict_args))
 161           where
 162             mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
 163                                 | otherwise               = voidTy
 164             ty_args = map mk_ty_arg all_tyvars
 165             env     = all_tyvars `zip` ty_args
 166     in
 167     zipWithDs mk_bind exports [0..]             `thenDs` \ export_binds ->
 168      -- don't scc (auto-)annotate the tuple itself.
 169     returnDs ((tup_id, tup_expr) : export_binds)
 170 \end{code}
 171
 172
 173 %************************************************************************
 174 %*                                                                      *
 175 \subsection[addAutoScc]{Adding automatic sccs}
 176 %*                                                                      *
 177 %************************************************************************
 178
 179 \begin{code}
 180 addAutoScc :: Maybe (Module, Group)     -- Module and group
 181            -> (Id, CoreExpr)
 182            -> (Id, CoreExpr)
 183
 184 addAutoScc mb_mod_grp pair@(bndr, core_expr)
 185   = case mb_mod_grp of
 186       Just (mod,grp)
 187        | worthSCC core_expr &&
 188          (opt_AutoSccsOnAllToplevs ||
 189           (isExported bndr && opt_AutoSccsOnExportedToplevs))
 190         -> (bndr, SCC (mkAutoCC bndr mod grp IsNotCafCC) core_expr)
 191       _ -> pair -- no auto-annotation.
 192
 193 worthSCC (SCC _ _) = False
 194 worthSCC (Con _ _) = False
 195 worthSCC core_expr = True
 196 \end{code}
 197
 198 If profiling and dealing with a dict binding, wrap the dict in "_scc_ DICT <dict>":
 199
 200 \begin{code}
 201 addDictScc var rhs
 202   | not ( opt_SccProfilingOn || opt_AutoSccsOnAllToplevs)
 203             -- the latter is so that -unprof-auto-scc-all adds dict sccs
 204     || not (isDictTy (idType var))
 205   = returnDs rhs                                -- That's easy: do nothing
 206
 207   | opt_CompilingGhcInternals
 208   = returnDs (SCC prel_dicts_cc rhs)
 209
 210   | otherwise
 211   = getModuleAndGroupDs         `thenDs` \ (mod, grp) ->
 212
 213         -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
 214     returnDs (SCC (mkAllDictsCC mod grp False) rhs)
 215
 216 prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
 217 \end{code}