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