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