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 PprStyle         ( PprStyle(..) )
  38 import Type             ( mkTyVarTy, isDictTy, instantiateTy
  39                         )
  40 import TyVar            ( tyVarSetToList, GenTyVar{-instance Eq-} )
  41 import TysPrim          ( voidTy )
  42 import Util             ( isIn, panic{-, pprTrace ToDo:rm-} )
  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 dsMonoBinds is_rec (AbsBinds [] [] exports binds)       -- Common special case
 110   = dsMonoBinds is_rec binds                    `thenDs` \ prs ->
 111     returnDs (prs ++ [(global, Var local) | (_, global, local) <- exports])
 112
 113 dsMonoBinds is_rec (AbsBinds all_tyvars dicts exports binds)
 114   = dsMonoBinds is_rec binds                            `thenDs` \ core_prs ->
 115     let
 116         core_binds | is_rec    = [Rec core_prs]
 117                    | otherwise = [NonRec b e | (b,e) <- core_prs]
 118
 119         tup_expr = mkLam all_tyvars dicts $
 120                    mkCoLetsAny core_binds $
 121                    mkTupleExpr locals
 122         locals    = [local | (_, _, local) <- exports]
 123         local_tys = map idType locals
 124     in
 125     newSysLocalDs (coreExprType tup_expr)               `thenDs` \ tup_id ->
 126     let
 127         dict_args    = map VarArg dicts
 128
 129         mk_bind (tyvars, global, local) n       -- locals !! n == local
 130           =     -- Need to make fresh locals to bind in the selector, because
 131                 -- some of the tyvars will be bound to voidTy
 132             newSysLocalsDs (map (instantiateTy env) local_tys)  `thenDs` \ locals' ->
 133             returnDs (global, mkLam tyvars dicts $
 134                               mkTupleSelector locals' (locals' !! n) $
 135                               mkValApp (mkTyApp (Var tup_id) ty_args) dict_args)
 136           where
 137             mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
 138                                 | otherwise               = voidTy
 139             ty_args = map mk_ty_arg all_tyvars
 140             env     = all_tyvars `zip` ty_args
 141     in
 142     zipWithDs mk_bind exports [0..]             `thenDs` \ export_binds ->
 143     returnDs ((tup_id, tup_expr) : export_binds)
 144 \end{code}
 145
 146 If profiling and dealing with a dict binding, wrap the dict in "_scc_ DICT <dict>":
 147
 148 \begin{code}
 149 addDictScc var rhs
 150   | not ( opt_SccProfilingOn || opt_AutoSccsOnAllToplevs)
 151             -- the latter is so that -unprof-auto-scc-all adds dict sccs
 152     || not (isDictTy (idType var))
 153   = returnDs rhs                                -- That's easy: do nothing
 154
 155   | opt_CompilingGhcInternals
 156   = returnDs (SCC prel_dicts_cc rhs)
 157
 158   | otherwise
 159   = getModuleAndGroupDs         `thenDs` \ (mod, grp) ->
 160
 161         -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
 162     returnDs (SCC (mkAllDictsCC mod grp False) rhs)
 163
 164 prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
 165 \end{code}