VECTORISE pragmas for type classes and instances
[ghc.git] / compiler / deSugar / Desugar.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 The Desugarer: turning HsSyn into Core.
7
8 \begin{code}
9 module Desugar ( deSugar, deSugarExpr ) where
10
11 import DynFlags
12 import StaticFlags
13 import HscTypes
14 import HsSyn
15 import TcRnTypes
16 import MkIface
17 import Id
18 import Name
19 import InstEnv
20 import Class
21 import Avail
22 import CoreSyn
23 import CoreSubst
24 import PprCore
25 import DsMonad
26 import DsExpr
27 import DsBinds
28 import DsForeign
29 import DsExpr           ()      -- Forces DsExpr to be compiled; DsBinds only
30                                 -- depends on DsExpr.hi-boot.
31 import Module
32 import RdrName
33 import NameSet
34 import NameEnv
35 import Rules
36 import CoreMonad        ( endPass, CoreToDo(..) )
37 import ErrUtils
38 import Outputable
39 import SrcLoc
40 import Coverage
41 import Util
42 import MonadUtils
43 import OrdList
44 import Data.List
45 import Data.IORef
46 \end{code}
47
48 %************************************************************************
49 %*                                                                      *
50 %*              The main function: deSugar
51 %*                                                                      *
52 %************************************************************************
53
54 \begin{code}
55 -- | Main entry point to the desugarer.
56 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
57 -- Can modify PCS by faulting in more declarations
58
59 deSugar hsc_env 
60         mod_loc
61         tcg_env@(TcGblEnv { tcg_mod          = mod,
62                             tcg_src          = hsc_src,
63                             tcg_type_env     = type_env,
64                             tcg_imports      = imports,
65                             tcg_exports      = exports,
66                             tcg_keep         = keep_var,
67                             tcg_th_splice_used = tc_splice_used,
68                             tcg_rdr_env      = rdr_env,
69                             tcg_fix_env      = fix_env,
70                             tcg_inst_env     = inst_env,
71                             tcg_fam_inst_env = fam_inst_env,
72                             tcg_warns        = warns,
73                             tcg_anns         = anns,
74                             tcg_binds        = binds,
75                             tcg_imp_specs    = imp_specs,
76                             tcg_ev_binds     = ev_binds,
77                             tcg_fords        = fords,
78                             tcg_rules        = rules,
79                             tcg_vects        = vects,
80                             tcg_tcs          = tcs,
81                             tcg_clss         = clss,
82                             tcg_insts        = insts,
83                             tcg_fam_insts    = fam_insts,
84                             tcg_hpc          = other_hpc_info })
85
86   = do { let dflags = hsc_dflags hsc_env
87              platform = targetPlatform dflags
88         ; showPass dflags "Desugar"
89
90         -- Desugar the program
91         ; let export_set = availsToNameSet exports
92         ; let auto_scc = mkAutoScc dflags mod export_set
93         ; let target = hscTarget dflags
94         ; let hpcInfo = emptyHpcInfo other_hpc_info
95         ; (msgs, mb_res)
96               <- case target of
97                    HscNothing ->
98                        return (emptyMessages,
99                                Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks))
100                    _        -> do
101                      (binds_cvr,ds_hpc_info, modBreaks)
102                          <- if (opt_Hpc
103                                   || target == HscInterpreted)
104                                && (not (isHsBoot hsc_src))
105                               then addCoverageTicksToBinds dflags mod mod_loc tcs binds 
106                               else return (binds, hpcInfo, emptyModBreaks)
107                      initDs hsc_env mod rdr_env type_env $ do
108                        do { ds_ev_binds <- dsEvBinds ev_binds
109                           ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
110                           ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
111                           ; (ds_fords, foreign_prs) <- dsForeigns fords
112                           ; ds_rules <- mapMaybeM dsRule rules
113                           ; ds_vects <- mapM dsVect vects
114                           ; let hpc_init
115                                   | opt_Hpc   = hpcInitCode platform mod ds_hpc_info
116                                   | otherwise = empty
117                           ; return ( ds_ev_binds
118                                    , foreign_prs `appOL` core_prs `appOL` spec_prs
119                                    , spec_rules ++ ds_rules, ds_vects
120                                    , ds_fords `appendStubC` hpc_init
121                                    , ds_hpc_info, modBreaks) }
122
123         ; case mb_res of {
124            Nothing -> return (msgs, Nothing) ;
125            Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks) -> do
126
127         {       -- Add export flags to bindings
128           keep_alive <- readIORef keep_var
129         ; let (rules_for_locals, rules_for_imps) 
130                    = partition isLocalRule all_rules
131               final_prs = addExportFlagsAndRules target
132                               export_set keep_alive rules_for_locals (fromOL all_prs)
133
134               final_pgm = combineEvBinds ds_ev_binds final_prs
135         -- Notice that we put the whole lot in a big Rec, even the foreign binds
136         -- When compiling PrelFloat, which defines data Float = F# Float#
137         -- we want F# to be in scope in the foreign marshalling code!
138         -- You might think it doesn't matter, but the simplifier brings all top-level
139         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
140
141         -- Lint result if necessary, and print
142         ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
143                (vcat [ pprCoreBindings final_pgm
144                      , pprRules rules_for_imps ])
145
146         ; (ds_binds, ds_rules_for_imps, ds_vects) 
147             <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0
148                          -- The simpleOptPgm gets rid of type 
149                          -- bindings plus any stupid dead code
150
151         ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
152
153         ; let used_names = mkUsedNames tcg_env
154         ; deps <- mkDependencies tcg_env
155
156         ; used_th <- readIORef tc_splice_used
157
158         ; let mod_guts = ModGuts {
159                 mg_module       = mod,
160                 mg_boot         = isHsBoot hsc_src,
161                 mg_exports      = exports,
162                 mg_deps         = deps,
163                 mg_used_names   = used_names,
164                 mg_used_th      = used_th,
165                 mg_dir_imps     = imp_mods imports,
166                 mg_rdr_env      = rdr_env,
167                 mg_fix_env      = fix_env,
168                 mg_warns        = warns,
169                 mg_anns         = anns,
170                 mg_tcs          = tcs,
171                 mg_clss         = clss,
172                 mg_insts        = insts,
173                 mg_fam_insts    = fam_insts,
174                 mg_inst_env     = inst_env,
175                 mg_fam_inst_env = fam_inst_env,
176                 mg_rules        = ds_rules_for_imps,
177                 mg_binds        = ds_binds,
178                 mg_foreign      = ds_fords,
179                 mg_hpc_info     = ds_hpc_info,
180                 mg_modBreaks    = modBreaks,
181                 mg_vect_decls   = ds_vects,
182                 mg_vect_info    = noVectInfo,
183                 mg_trust_pkg    = imp_trust_own_pkg imports
184               }
185         ; return (msgs, Just mod_guts)
186         }}}
187
188 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
189 dsImpSpecs imp_specs
190  = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
191       ; let (spec_binds, spec_rules) = unzip spec_prs
192       ; return (concatOL spec_binds, spec_rules) }
193
194 combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
195 -- Top-level bindings can include coercion bindings, but not via superclasses
196 -- See Note [Top-level evidence]
197 combineEvBinds [] val_prs 
198   = [Rec val_prs]
199 combineEvBinds (NonRec b r : bs) val_prs
200   | isId b    = combineEvBinds bs ((b,r):val_prs)
201   | otherwise = NonRec b r : combineEvBinds bs val_prs
202 combineEvBinds (Rec prs : bs) val_prs 
203   = combineEvBinds bs (prs ++ val_prs)
204 \end{code}
205
206 Note [Top-level evidence]
207 ~~~~~~~~~~~~~~~~~~~~~~~~~
208 Top-level evidence bindings may be mutually recursive with the top-level value
209 bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
210 because the occurrence analyser doesn't teke account of type/coercion variables
211 when computing dependencies.  
212
213 So we pull out the type/coercion variables (which are in dependency order),
214 and Rec the rest.
215
216
217 \begin{code}
218 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
219 mkAutoScc dflags mod exports
220   | not opt_SccProfilingOn      -- No profiling
221   = NoSccs              
222     -- Add auto-scc on all top-level things
223   | dopt Opt_AutoSccsOnAllToplevs dflags
224   = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
225     -- See #1641.  This is pretty yucky, but I can't see a better way
226     -- to identify compiler-generated Ids, and at least this should
227     -- catch them all.
228     -- Only on exported things
229   | dopt Opt_AutoSccsOnExportedToplevs dflags
230   = AddSccs mod (\id -> idName id `elemNameSet` exports)
231   | otherwise
232   = NoSccs
233
234 deSugarExpr :: HscEnv
235             -> Module -> GlobalRdrEnv -> TypeEnv 
236             -> LHsExpr Id
237             -> IO (Messages, Maybe CoreExpr)
238 -- Prints its own errors; returns Nothing if error occurred
239
240 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
241     let dflags = hsc_dflags hsc_env
242     showPass dflags "Desugar"
243
244     -- Do desugaring
245     (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
246                                    dsLExpr tc_expr
247
248     case mb_core_expr of
249       Nothing   -> return (msgs, Nothing)
250       Just expr -> do
251
252         -- Dump output
253         dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
254
255         return (msgs, Just expr)
256 \end{code}
257
258 %************************************************************************
259 %*                                                                      *
260 %*              Add rules and export flags to binders
261 %*                                                                      *
262 %************************************************************************
263
264 \begin{code}
265 addExportFlagsAndRules 
266     :: HscTarget -> NameSet -> NameSet -> [CoreRule]
267     -> [(Id, t)] -> [(Id, t)]
268 addExportFlagsAndRules target exports keep_alive rules prs
269   = mapFst add_one prs
270   where
271     add_one bndr = add_rules name (add_export name bndr)
272        where
273          name = idName bndr
274
275     ---------- Rules --------
276         -- See Note [Attach rules to local ids]
277         -- NB: the binder might have some existing rules,
278         -- arising from specialisation pragmas
279     add_rules name bndr
280         | Just rules <- lookupNameEnv rule_base name
281         = bndr `addIdSpecialisations` rules
282         | otherwise
283         = bndr
284     rule_base = extendRuleBaseList emptyRuleBase rules
285
286     ---------- Export flag --------
287     -- See Note [Adding export flags]
288     add_export name bndr
289         | dont_discard name = setIdExported bndr
290         | otherwise         = bndr
291
292     dont_discard :: Name -> Bool
293     dont_discard name = is_exported name
294                      || name `elemNameSet` keep_alive
295
296         -- In interactive mode, we don't want to discard any top-level
297         -- entities at all (eg. do not inline them away during
298         -- simplification), and retain them all in the TypeEnv so they are
299         -- available from the command line.
300         --
301         -- isExternalName separates the user-defined top-level names from those
302         -- introduced by the type checker.
303     is_exported :: Name -> Bool
304     is_exported | target == HscInterpreted = isExternalName
305                 | otherwise                = (`elemNameSet` exports)
306 \end{code}
307
308
309 Note [Adding export flags]
310 ~~~~~~~~~~~~~~~~~~~~~~~~~~
311 Set the no-discard flag if either 
312         a) the Id is exported
313         b) it's mentioned in the RHS of an orphan rule
314         c) it's in the keep-alive set
315
316 It means that the binding won't be discarded EVEN if the binding
317 ends up being trivial (v = w) -- the simplifier would usually just 
318 substitute w for v throughout, but we don't apply the substitution to
319 the rules (maybe we should?), so this substitution would make the rule
320 bogus.
321
322 You might wonder why exported Ids aren't already marked as such;
323 it's just because the type checker is rather busy already and
324 I didn't want to pass in yet another mapping.
325
326 Note [Attach rules to local ids]
327 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
328 Find the rules for locally-defined Ids; then we can attach them
329 to the binders in the top-level bindings
330
331 Reason
332   - It makes the rules easier to look up
333   - It means that transformation rules and specialisations for
334     locally defined Ids are handled uniformly
335   - It keeps alive things that are referred to only from a rule
336     (the occurrence analyser knows about rules attached to Ids)
337   - It makes sure that, when we apply a rule, the free vars
338     of the RHS are more likely to be in scope
339   - The imported rules are carried in the in-scope set
340     which is extended on each iteration by the new wave of
341     local binders; any rules which aren't on the binding will
342     thereby get dropped
343
344
345 %************************************************************************
346 %*                                                                      *
347 %*              Desugaring transformation rules
348 %*                                                                      *
349 %************************************************************************
350
351 \begin{code}
352 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
353 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
354   = putSrcSpanDs loc $ 
355     do  { let bndrs' = [var | RuleBndr (L _ var) <- vars]
356
357         ; lhs' <- unsetDOptM Opt_EnableRewriteRules $
358                   unsetWOptM Opt_WarnIdentities $
359                   dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
360
361         ; rhs' <- dsLExpr rhs
362
363         -- Substitute the dict bindings eagerly,
364         -- and take the body apart into a (f args) form
365         ; case decomposeRuleLhs bndrs' lhs' of {
366                 Left msg -> do { warnDs msg; return Nothing } ;
367                 Right (final_bndrs, fn_id, args) -> do
368         
369         { let is_local = isLocalId fn_id
370                 -- NB: isLocalId is False of implicit Ids.  This is good becuase
371                 -- we don't want to attach rules to the bindings of implicit Ids, 
372                 -- because they don't show up in the bindings until just before code gen
373               fn_name   = idName fn_id
374               final_rhs = simpleOptExpr rhs'    -- De-crap it
375               rule      = mkRule False {- Not auto -} is_local 
376                                  name act fn_name final_bndrs args final_rhs
377         ; return (Just rule)
378         } } }
379 \end{code}
380
381 Note [Desugaring RULE left hand sides]
382 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
383 For the LHS of a RULE we do *not* want to desugar
384     [x]   to    build (\cn. x `c` n)
385 We want to leave explicit lists simply as chains
386 of cons's. We can achieve that slightly indirectly by
387 switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
388
389 That keeps the desugaring of list comprehensions simple too.
390
391
392
393 Nor do we want to warn of conversion identities on the LHS;
394 the rule is precisly to optimise them:
395   {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
396
397
398 %************************************************************************
399 %*                                                                      *
400 %*              Desugaring vectorisation declarations
401 %*                                                                      *
402 %************************************************************************
403
404 \begin{code}
405 dsVect :: LVectDecl Id -> DsM CoreVect
406 dsVect (L loc (HsVect (L _ v) rhs))
407   = putSrcSpanDs loc $ 
408     do { rhs' <- fmapMaybeM dsLExpr rhs
409        ; return $ Vect v rhs'
410        }
411 dsVect (L _loc (HsNoVect (L _ v)))
412   = return $ NoVect v
413 dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
414   = return $ VectType isScalar tycon rhs_tycon
415 dsVect vd@(L _ (HsVectTypeIn _ _ _))
416   = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
417 dsVect (L _loc (HsVectClassOut cls))
418   = return $ VectClass (classTyCon cls)
419 dsVect vc@(L _ (HsVectClassIn _))
420   = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)
421 dsVect (L _loc (HsVectInstOut isScalar inst))
422   = return $ VectInst isScalar (instanceDFunId inst)
423 dsVect vi@(L _ (HsVectInstIn _ _))
424   = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)
425 \end{code}