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
  62 dsBinds :: Bool   -- if candidate, auto add scc's on toplevs ?
  63         -> TypecheckedHsBinds
  64         -> DsM [CoreBinding]
  65
  66 dsBinds _ EmptyBinds                 = returnDs []
  67 dsBinds auto_scc (ThenBinds binds_1 binds_2)
  68   = andDs (++) (dsBinds auto_scc binds_1) (dsBinds auto_scc binds_2)
  69
  70 dsBinds auto_scc (MonoBind binds sigs is_rec)
  71   = dsMonoBinds auto_scc is_rec binds  `thenDs` \ prs ->
  72     returnDs (if is_rec then
  73                 [Rec prs]
  74               else
  75                 [NonRec binder rhs | (binder,rhs) <- prs]
  76     )
  77 \end{code}
  78
  79
  80 %************************************************************************
  81 %*                                                                      *
  82 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
  83 %*                                                                      *
  84 %************************************************************************
  85
  86 \begin{code}
  87 dsMonoBinds :: Bool             -- False => don't (auto-)annotate scc on toplevs.
  88             -> RecFlag
  89             -> TypecheckedMonoBinds
  90             -> DsM [(Id,CoreExpr)]
  91
  92 dsMonoBinds _ is_rec EmptyMonoBinds = returnDs []
  93
  94 dsMonoBinds auto_scc is_rec (AndMonoBinds  binds_1 binds_2)
  95   = andDs (++) (dsMonoBinds auto_scc is_rec binds_1) (dsMonoBinds auto_scc is_rec binds_2)
  96
  97 dsMonoBinds _ is_rec (CoreMonoBind var core_expr)
  98   = returnDs [(var, core_expr)]
  99
 100 dsMonoBinds _ is_rec (VarMonoBind var expr)
 101   = dsExpr expr                 `thenDs` \ core_expr ->
 102
 103         -- Dictionary bindings are always VarMonoBinds, so
 104         -- we only need do this here
 105     addDictScc var core_expr    `thenDs` \ core_expr' ->
 106
 107     returnDs [(var, core_expr')]
 108
 109 dsMonoBinds auto_scc is_rec (FunMonoBind fun _ matches locn)
 110   = putSrcLocDs locn    $
 111     matchWrapper (FunMatch fun) matches error_string    `thenDs` \ (args, body) ->
 112     addAutoScc auto_scc (fun, mkValLam args body)       `thenDs` \ pair ->
 113     returnDs [pair]
 114   where
 115     error_string = "function " ++ showForErr fun
 116
 117 dsMonoBinds _ is_rec (PatMonoBind pat grhss_and_binds locn)
 118   = putSrcLocDs locn $
 119     dsGuarded grhss_and_binds           `thenDs` \ body_expr ->
 120     mkSelectorBinds pat body_expr
 121
 122         -- Common special case: no type or dictionary abstraction
 123 dsMonoBinds auto_scc is_rec (AbsBinds [] [] exports binds)
 124   = dsMonoBinds False is_rec binds                      `thenDs` \ prs ->
 125     mapDs (addAutoScc auto_scc) [(global, Var local) | (_, global, local) <- exports] `thenDs` \ exports' ->
 126     returnDs (prs ++ exports')
 127
 128         -- Another common case: one exported variable
 129         -- All non-recursive bindings come through this way
 130 dsMonoBinds auto_scc is_rec (AbsBinds all_tyvars dicts [(tyvars, global, local)] binds)
 131   = ASSERT( all (`elem` tyvars) all_tyvars )
 132     dsMonoBinds False is_rec binds                      `thenDs` \ core_prs ->
 133     let
 134         core_binds | is_rec    = [Rec core_prs]
 135                    | otherwise = [NonRec b e | (b,e) <- core_prs]
 136     in
 137     addAutoScc auto_scc (global, mkLam tyvars dicts $
 138                                  mkCoLetsAny core_binds (Var local)) `thenDs` \ global' ->
 139     returnDs [global']
 140
 141 dsMonoBinds auto_scc is_rec (AbsBinds all_tyvars dicts exports binds)
 142   = dsMonoBinds False is_rec binds                      `thenDs` \ core_prs ->
 143     let
 144         core_binds | is_rec    = [Rec core_prs]
 145                    | otherwise = [NonRec b e | (b,e) <- core_prs]
 146
 147         tup_expr = mkLam all_tyvars dicts $
 148                    mkCoLetsAny core_binds $
 149                    mkTupleExpr locals
 150         locals    = [local | (_, _, local) <- exports]
 151         local_tys = map idType locals
 152     in
 153     newSysLocalDs (coreExprType tup_expr)               `thenDs` \ tup_id ->
 154     let
 155         dict_args    = map VarArg dicts
 156
 157         mk_bind (tyvars, global, local) n       -- locals !! n == local
 158           =     -- Need to make fresh locals to bind in the selector, because
 159                 -- some of the tyvars will be bound to voidTy
 160             newSysLocalsDs (map (instantiateTy env) local_tys)  `thenDs` \ locals' ->
 161             addAutoScc auto_scc
 162                        (global, mkLam tyvars dicts $
 163                                 mkTupleSelector locals' (locals' !! n) $
 164                                 mkValApp (mkTyApp (Var tup_id) ty_args) dict_args)
 165           where
 166             mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
 167                                 | otherwise               = voidTy
 168             ty_args = map mk_ty_arg all_tyvars
 169             env     = all_tyvars `zip` ty_args
 170     in
 171     zipWithDs mk_bind exports [0..]             `thenDs` \ export_binds ->
 172      -- don't scc (auto-)annotate the tuple itself.
 173     returnDs ((tup_id, tup_expr) : export_binds)
 174 \end{code}
 175
 176
 177 %************************************************************************
 178 %*                                                                      *
 179 \subsection[addAutoScc]{Adding automatic sccs}
 180 %*                                                                      *
 181 %************************************************************************
 182
 183 \begin{code}
 184 addAutoScc :: Bool              -- if needs be, decorate toplevs?
 185            -> (Id, CoreExpr)
 186            -> DsM (Id, CoreExpr)
 187
 188 addAutoScc auto_scc_candidate pair@(bndr, core_expr)
 189  | auto_scc_candidate && worthSCC core_expr &&
 190    (opt_AutoSccsOnAllToplevs || (isExported bndr && opt_AutoSccsOnExportedToplevs))
 191      = getModuleAndGroupDs `thenDs` \ (mod,grp) ->
 192        returnDs (bndr, SCC (mkAutoCC bndr mod grp IsNotCafCC) core_expr)
 193  | otherwise
 194      = returnDs pair
 195
 196 worthSCC (SCC _ _) = False
 197 worthSCC (Con _ _) = False
 198 worthSCC core_expr = True
 199 \end{code}
 200
 201 If profiling and dealing with a dict binding, wrap the dict in "_scc_ DICT <dict>":
 202
 203 \begin{code}
 204 addDictScc var rhs
 205   | not ( opt_SccProfilingOn || opt_AutoSccsOnAllToplevs)
 206             -- the latter is so that -unprof-auto-scc-all adds dict sccs
 207     || not (isDictTy (idType var))
 208   = returnDs rhs                                -- That's easy: do nothing
 209
 210   | opt_CompilingGhcInternals
 211   = returnDs (SCC prel_dicts_cc rhs)
 212
 213   | otherwise
 214   = getModuleAndGroupDs         `thenDs` \ (mod, grp) ->
 215
 216         -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
 217     returnDs (SCC (mkAllDictsCC mod grp False) rhs)
 218
 219 prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
 220 \end{code}