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