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