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 IMPORT_DELOOPER(DsLoop)         -- break dsExpr-ish loop
  17
  18 import HsSyn            -- lots of things
  19 import CoreSyn          -- lots of things
  20 import CoreUtils        ( coreExprType )
  21 import TcHsSyn          ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
  22                           SYN_IE(TypecheckedMonoBinds),
  23                           SYN_IE(TypecheckedPat)
  24                         )
  25 import DsMonad
  26 import DsGRHSs          ( dsGuarded )
  27 import DsUtils
  28 import Match            ( matchWrapper )
  29
  30 import CmdLineOpts      ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs,
  31                           opt_AutoSccsOnExportedToplevs, opt_CompilingGhcInternals )
  32 import CostCentre       ( mkAutoCC, IsCafCC(..), mkAllDictsCC, preludeDictsCostCentre )
  33 import Id               ( idType, SYN_IE(DictVar), GenId, SYN_IE(Id) )
  34 import ListSetOps       ( minusList, intersectLists )
  35 import Name             ( isExported )
  36 import PprType          ( GenType )
  37 import Outputable       ( PprStyle(..) )
  38 import Type             ( mkTyVarTy, isDictTy, instantiateTy
  39                         )
  40 import TyVar            ( tyVarSetToList, GenTyVar{-instance Eq-} )
  41 import TysPrim          ( voidTy )
  42 import Util             ( isIn, panic, assertPanic  )
  43 \end{code}
  44
  45 %************************************************************************
  46 %*                                                                      *
  47 \subsection[toplevel-and-regular-DsBinds]{Regular and top-level @dsBinds@}
  48 %*                                                                      *
  49 %************************************************************************
  50
  51 Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be
  52 that some of the binders are of unboxed type.  This is sorted out when
  53 the caller wraps the bindings round an expression.
  54
  55 \begin{code}
  56 dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding]
  57
  58 dsBinds EmptyBinds                   = returnDs []
  59 dsBinds (ThenBinds  binds_1 binds_2) = andDs (++) (dsBinds binds_1) (dsBinds binds_2)
  60
  61 dsBinds (MonoBind binds sigs is_rec)
  62   = dsMonoBinds is_rec binds            `thenDs` \ prs ->
  63     returnDs (if is_rec then
  64                 [Rec prs]
  65               else
  66                 [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 :: RecFlag -> TypecheckedMonoBinds -> DsM [(Id,CoreExpr)]
  79
  80 dsMonoBinds is_rec EmptyMonoBinds = returnDs []
  81
  82 dsMonoBinds is_rec (AndMonoBinds  binds_1 binds_2)
  83   = andDs (++) (dsMonoBinds is_rec binds_1) (dsMonoBinds is_rec binds_2)
  84
  85 dsMonoBinds is_rec (CoreMonoBind var core_expr)
  86   = returnDs [(var, core_expr)]
  87
  88 dsMonoBinds is_rec (VarMonoBind var expr)
  89   = dsExpr expr                 `thenDs` \ core_expr ->
  90
  91         -- Dictionary bindings are always VarMonoBinds, so
  92         -- we only need do this here
  93     addDictScc var core_expr    `thenDs` \ core_expr' ->
  94
  95     returnDs [(var, core_expr')]
  96
  97 dsMonoBinds is_rec (FunMonoBind fun _ matches locn)
  98   = putSrcLocDs locn    $
  99     matchWrapper (FunMatch fun) matches error_string    `thenDs` \ (args, body) ->
 100     returnDs [(fun, mkValLam args body)]
 101   where
 102     error_string = "function " ++ showForErr fun
 103
 104 dsMonoBinds is_rec (PatMonoBind pat grhss_and_binds locn)
 105   = putSrcLocDs locn $
 106     dsGuarded grhss_and_binds                   `thenDs` \ body_expr ->
 107     mkSelectorBinds pat body_expr
 108
 109         -- Common special case: no type or dictionary abstraction
 110 dsMonoBinds is_rec (AbsBinds [] [] exports binds)
 111   = dsMonoBinds is_rec binds                    `thenDs` \ prs ->
 112     returnDs (prs ++ [(global, Var local) | (_, global, local) <- exports])
 113
 114         -- Another common case: one exported variable
 115         -- All non-recursive bindings come through this way
 116 dsMonoBinds is_rec (AbsBinds all_tyvars dicts [(tyvars, global, local)] binds)
 117   = ASSERT( all (`elem` tyvars) all_tyvars )
 118     dsMonoBinds is_rec binds                            `thenDs` \ core_prs ->
 119     let
 120         core_binds | is_rec    = [Rec core_prs]
 121                    | otherwise = [NonRec b e | (b,e) <- core_prs]
 122     in
 123     returnDs [(global, mkLam tyvars dicts $ mkCoLetsAny core_binds (Var local))]
 124
 125 dsMonoBinds is_rec (AbsBinds all_tyvars dicts exports binds)
 126   = dsMonoBinds is_rec binds                            `thenDs` \ core_prs ->
 127     let
 128         core_binds | is_rec    = [Rec core_prs]
 129                    | otherwise = [NonRec b e | (b,e) <- core_prs]
 130
 131         tup_expr = mkLam all_tyvars dicts $
 132                    mkCoLetsAny core_binds $
 133                    mkTupleExpr locals
 134         locals    = [local | (_, _, local) <- exports]
 135         local_tys = map idType locals
 136     in
 137     newSysLocalDs (coreExprType tup_expr)               `thenDs` \ tup_id ->
 138     let
 139         dict_args    = map VarArg dicts
 140
 141         mk_bind (tyvars, global, local) n       -- locals !! n == local
 142           =     -- Need to make fresh locals to bind in the selector, because
 143                 -- some of the tyvars will be bound to voidTy
 144             newSysLocalsDs (map (instantiateTy env) local_tys)  `thenDs` \ locals' ->
 145             returnDs (global, mkLam tyvars dicts $
 146                               mkTupleSelector locals' (locals' !! n) $
 147                               mkValApp (mkTyApp (Var tup_id) ty_args) dict_args)
 148           where
 149             mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
 150                                 | otherwise               = voidTy
 151             ty_args = map mk_ty_arg all_tyvars
 152             env     = all_tyvars `zip` ty_args
 153     in
 154     zipWithDs mk_bind exports [0..]             `thenDs` \ export_binds ->
 155     returnDs ((tup_id, tup_expr) : export_binds)
 156 \end{code}
 157
 158 If profiling and dealing with a dict binding, wrap the dict in "_scc_ DICT <dict>":
 159
 160 \begin{code}
 161 addDictScc var rhs
 162   | not ( opt_SccProfilingOn || opt_AutoSccsOnAllToplevs)
 163             -- the latter is so that -unprof-auto-scc-all adds dict sccs
 164     || not (isDictTy (idType var))
 165   = returnDs rhs                                -- That's easy: do nothing
 166
 167   | opt_CompilingGhcInternals
 168   = returnDs (SCC prel_dicts_cc rhs)
 169
 170   | otherwise
 171   = getModuleAndGroupDs         `thenDs` \ (mod, grp) ->
 172
 173         -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
 174     returnDs (SCC (mkAllDictsCC mod grp False) rhs)
 175
 176 prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
 177 \end{code}