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