Desugar.hs 22.2 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

Simon Marlow's avatar
Simon Marlow committed
5 6

The Desugarer: turning HsSyn into Core.
Austin Seipp's avatar
Austin Seipp committed
7
-}
8

9 10
{-# LANGUAGE CPP #-}

11
module Desugar ( deSugar, deSugarExpr ) where
12

Simon Marlow's avatar
Simon Marlow committed
13 14 15 16
import DynFlags
import HscTypes
import HsSyn
import TcRnTypes
17
import TcRnMonad ( finalSafeMode, fixSafeInstances )
Simon Marlow's avatar
Simon Marlow committed
18 19 20
import MkIface
import Id
import Name
21
import Type
22
import FamInstEnv
23
import Coercion
24 25
import InstEnv
import Class
26
import Avail
27
import CoreSyn
28
import CoreFVs( exprsSomeFreeVars )
29
import CoreSubst
Simon Marlow's avatar
Simon Marlow committed
30
import PprCore
31
import DsMonad
Simon Marlow's avatar
Simon Marlow committed
32 33 34
import DsExpr
import DsBinds
import DsForeign
Simon Marlow's avatar
Simon Marlow committed
35
import Module
36
import NameSet
37
import NameEnv
Simon Marlow's avatar
Simon Marlow committed
38
import Rules
39 40
import TysPrim (eqReprPrimTyCon)
import TysWiredIn (coercibleTyCon )
41
import BasicTypes       ( Activation(.. ), competesWith, pprRuleName )
42 43
import CoreMonad        ( CoreToDo(..) )
import CoreLint         ( endPassIO )
44
import MkCore
45
import VarSet
46
import FastString
Simon Marlow's avatar
Simon Marlow committed
47
import ErrUtils
48
import Outputable
Simon Marlow's avatar
Simon Marlow committed
49
import SrcLoc
andy@galois.com's avatar
andy@galois.com committed
50
import Coverage
51
import Util
52 53
import MonadUtils
import OrdList
54
import StaticPtrTable
55
import Data.List
Simon Marlow's avatar
Simon Marlow committed
56
import Data.IORef
57
import Control.Monad( when )
58

Austin Seipp's avatar
Austin Seipp committed
59 60 61 62 63 64 65
{-
************************************************************************
*                                                                      *
*              The main function: deSugar
*                                                                      *
************************************************************************
-}
66

67
-- | Main entry point to the desugarer.
68
deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
69 70
-- Can modify PCS by faulting in more declarations

71
deSugar hsc_env
andy@galois.com's avatar
andy@galois.com committed
72
        mod_loc
73
        tcg_env@(TcGblEnv { tcg_mod          = mod,
74 75 76 77
                            tcg_src          = hsc_src,
                            tcg_type_env     = type_env,
                            tcg_imports      = imports,
                            tcg_exports      = exports,
78
                            tcg_keep         = keep_var,
79 80
                            tcg_th_splice_used = tc_splice_used,
                            tcg_rdr_env      = rdr_env,
81 82 83 84 85 86 87
                            tcg_fix_env      = fix_env,
                            tcg_inst_env     = inst_env,
                            tcg_fam_inst_env = fam_inst_env,
                            tcg_warns        = warns,
                            tcg_anns         = anns,
                            tcg_binds        = binds,
                            tcg_imp_specs    = imp_specs,
GregWeber's avatar
GregWeber committed
88
                            tcg_dependent_files = dependent_files,
89 90 91 92
                            tcg_ev_binds     = ev_binds,
                            tcg_fords        = fords,
                            tcg_rules        = rules,
                            tcg_vects        = vects,
cactus's avatar
cactus committed
93
                            tcg_patsyns      = patsyns,
94
                            tcg_tcs          = tcs,
95 96
                            tcg_insts        = insts,
                            tcg_fam_insts    = fam_insts,
97
                            tcg_hpc          = other_hpc_info})
98

99
  = do { let dflags = hsc_dflags hsc_env
100
             print_unqual = mkPrintUnqualified dflags rdr_env
101
        ; showPass dflags "Desugar"
102

103
        -- Desugar the program
104
        ; let export_set = availsToNameSet exports
105 106 107 108
              target     = hscTarget dflags
              hpcInfo    = emptyHpcInfo other_hpc_info

        ; (binds_cvr, ds_hpc_info, modBreaks)
109
                         <- if not (isHsBoot hsc_src)
110 111
                              then addTicksToBinds dflags mod mod_loc export_set
                                          (typeEnvTyCons type_env) binds
112
                              else return (binds, hpcInfo, emptyModBreaks)
113

114
        ; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $
115
                       do { ds_ev_binds <- dsEvBinds ev_binds
116
                          ; core_prs <- dsTopLHsBinds binds_cvr
117
                          ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
118 119 120
                          ; (ds_fords, foreign_prs) <- dsForeigns fords
                          ; ds_rules <- mapMaybeM dsRule rules
                          ; ds_vects <- mapM dsVect vects
121 122
                          ; stBinds <- dsGetStaticBindsVar >>=
                                           liftIO . readIORef
123
                          ; let hpc_init
ian@well-typed.com's avatar
ian@well-typed.com committed
124
                                  | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
125
                                  | otherwise = empty
126 127 128
                                -- Stub to insert the static entries of the
                                -- module into the static pointer table
                                spt_init = sptInitCode mod stBinds
129
                          ; return ( ds_ev_binds
130
                                   , foreign_prs `appOL` core_prs `appOL` spec_prs
131
                                                 `appOL` toOL (map snd stBinds)
132
                                   , spec_rules ++ ds_rules, ds_vects
133 134
                                   , ds_fords `appendStubC` hpc_init
                                              `appendStubC` spt_init) }
135

136 137
        ; case mb_res of {
           Nothing -> return (msgs, Nothing) ;
138
           Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> do
sof's avatar
sof committed
139

140
     do {       -- Add export flags to bindings
141
          keep_alive <- readIORef keep_var
142 143 144
        ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
              final_prs = addExportFlagsAndRules target export_set keep_alive
                                                 rules_for_locals (fromOL all_prs)
145 146

              final_pgm = combineEvBinds ds_ev_binds final_prs
147 148 149 150 151
        -- Notice that we put the whole lot in a big Rec, even the foreign binds
        -- When compiling PrelFloat, which defines data Float = F# Float#
        -- we want F# to be in scope in the foreign marshalling code!
        -- You might think it doesn't matter, but the simplifier brings all top-level
        -- things into the in-scope set before simplifying; so we get no unfolding for F#!
152

153
#ifdef DEBUG
dimitris's avatar
dimitris committed
154
          -- Debug only as pre-simple-optimisation program may be really big
155
        ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
156
#endif
157
        ; (ds_binds, ds_rules_for_imps, ds_vects)
158
            <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0
159
                         -- The simpleOptPgm gets rid of type
160
                         -- bindings plus any stupid dead code
sof's avatar
sof committed
161

162
        ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
163

164
        ; let used_names = mkUsedNames tcg_env
165
        ; deps <- mkDependencies tcg_env
166

167
        ; used_th <- readIORef tc_splice_used
GregWeber's avatar
GregWeber committed
168
        ; dep_files <- readIORef dependent_files
169
        ; safe_mode <- finalSafeMode dflags tcg_env
170 171

        ; let mod_guts = ModGuts {
172
                mg_module       = mod,
173
                mg_hsc_src      = hsc_src,
174
                mg_loc          = mkFileSrcSpan mod_loc,
175
                mg_exports      = exports,
176
                mg_deps         = deps,
177
                mg_used_names   = used_names,
178 179
                mg_used_th      = used_th,
                mg_dir_imps     = imp_mods imports,
180 181 182 183 184
                mg_rdr_env      = rdr_env,
                mg_fix_env      = fix_env,
                mg_warns        = warns,
                mg_anns         = anns,
                mg_tcs          = tcs,
185
                mg_insts        = fixSafeInstances safe_mode insts,
186 187 188
                mg_fam_insts    = fam_insts,
                mg_inst_env     = inst_env,
                mg_fam_inst_env = fam_inst_env,
189
                mg_patsyns      = patsyns,
190 191 192 193
                mg_rules        = ds_rules_for_imps,
                mg_binds        = ds_binds,
                mg_foreign      = ds_fords,
                mg_hpc_info     = ds_hpc_info,
194
                mg_modBreaks    = modBreaks,
195
                mg_vect_decls   = ds_vects,
196
                mg_vect_info    = noVectInfo,
197
                mg_safe_haskell = safe_mode,
GregWeber's avatar
GregWeber committed
198 199
                mg_trust_pkg    = imp_trust_own_pkg imports,
                mg_dependent_files = dep_files
200
              }
201
        ; return (msgs, Just mod_guts)
202
        }}}
203

204 205 206 207 208 209
mkFileSrcSpan :: ModLocation -> SrcSpan
mkFileSrcSpan mod_loc
  = case ml_hs_file mod_loc of
      Just file_path -> mkGeneralSrcSpan (mkFastString file_path)
      Nothing        -> interactiveSrcSpan   -- Presumably

210 211 212 213 214
dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
dsImpSpecs imp_specs
 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
      ; let (spec_binds, spec_rules) = unzip spec_prs
      ; return (concatOL spec_binds, spec_rules) }
215

batterseapower's avatar
batterseapower committed
216
combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
217 218
-- Top-level bindings can include coercion bindings, but not via superclasses
-- See Note [Top-level evidence]
219
combineEvBinds [] val_prs
220
  = [Rec val_prs]
batterseapower's avatar
batterseapower committed
221
combineEvBinds (NonRec b r : bs) val_prs
222 223
  | isId b    = combineEvBinds bs ((b,r):val_prs)
  | otherwise = NonRec b r : combineEvBinds bs val_prs
224
combineEvBinds (Rec prs : bs) val_prs
225 226
  = combineEvBinds bs (prs ++ val_prs)

Austin Seipp's avatar
Austin Seipp committed
227
{-
228 229 230 231 232
Note [Top-level evidence]
~~~~~~~~~~~~~~~~~~~~~~~~~
Top-level evidence bindings may be mutually recursive with the top-level value
bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
because the occurrence analyser doesn't teke account of type/coercion variables
233
when computing dependencies.
234 235 236

So we pull out the type/coercion variables (which are in dependency order),
and Rec the rest.
Austin Seipp's avatar
Austin Seipp committed
237
-}
238

239 240 241 242 243 244 245 246 247 248
deSugarExpr :: HscEnv -> LHsExpr Id -> IO (Messages, Maybe CoreExpr)

deSugarExpr hsc_env tc_expr
  = do { let dflags       = hsc_dflags hsc_env
             icntxt       = hsc_IC hsc_env
             rdr_env      = ic_rn_gbl_env icntxt
             type_env     = mkTypeEnvWithImplicits (ic_tythings icntxt)
             fam_insts    = snd (ic_instances icntxt)
             fam_inst_env = extendFamInstEnvList emptyFamInstEnv fam_insts
             -- This stuff is a half baked version of TcRnDriver.setInteractiveContext
249

250
       ; showPass dflags "Desugar"
251

252
         -- Do desugaring
253
       ; (msgs, mb_core_expr) <- initDs hsc_env (icInteractiveModule icntxt) rdr_env
254
                                        type_env fam_inst_env $
255
                                 dsLExpr tc_expr
256

257 258 259
       ; case mb_core_expr of
            Nothing   -> return ()
            Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
260

261
       ; return (msgs, mb_core_expr) }
262

Austin Seipp's avatar
Austin Seipp committed
263 264 265 266 267 268 269
{-
************************************************************************
*                                                                      *
*              Add rules and export flags to binders
*                                                                      *
************************************************************************
-}
270

271
addExportFlagsAndRules
272 273 274 275
    :: HscTarget -> NameSet -> NameSet -> [CoreRule]
    -> [(Id, t)] -> [(Id, t)]
addExportFlagsAndRules target exports keep_alive rules prs
  = mapFst add_one prs
276
  where
277 278 279 280 281
    add_one bndr = add_rules name (add_export name bndr)
       where
         name = idName bndr

    ---------- Rules --------
282 283 284
        -- See Note [Attach rules to local ids]
        -- NB: the binder might have some existing rules,
        -- arising from specialisation pragmas
285
    add_rules name bndr
286 287 288 289
        | Just rules <- lookupNameEnv rule_base name
        = bndr `addIdSpecialisations` rules
        | otherwise
        = bndr
290 291 292 293 294
    rule_base = extendRuleBaseList emptyRuleBase rules

    ---------- Export flag --------
    -- See Note [Adding export flags]
    add_export name bndr
295 296
        | dont_discard name = setIdExported bndr
        | otherwise         = bndr
297

298 299
    dont_discard :: Name -> Bool
    dont_discard name = is_exported name
300 301 302 303 304 305 306 307 308
                     || name `elemNameSet` keep_alive

        -- In interactive mode, we don't want to discard any top-level
        -- entities at all (eg. do not inline them away during
        -- simplification), and retain them all in the TypeEnv so they are
        -- available from the command line.
        --
        -- isExternalName separates the user-defined top-level names from those
        -- introduced by the type checker.
309
    is_exported :: Name -> Bool
310 311
    is_exported | targetRetainsAllBindings target = isExternalName
                | otherwise                       = (`elemNameSet` exports)
sof's avatar
sof committed
312

Austin Seipp's avatar
Austin Seipp committed
313
{-
314 315
Note [Adding export flags]
~~~~~~~~~~~~~~~~~~~~~~~~~~
316 317 318 319
Set the no-discard flag if either
        a) the Id is exported
        b) it's mentioned in the RHS of an orphan rule
        c) it's in the keep-alive set
320 321

It means that the binding won't be discarded EVEN if the binding
322
ends up being trivial (v = w) -- the simplifier would usually just
323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348
substitute w for v throughout, but we don't apply the substitution to
the rules (maybe we should?), so this substitution would make the rule
bogus.

You might wonder why exported Ids aren't already marked as such;
it's just because the type checker is rather busy already and
I didn't want to pass in yet another mapping.

Note [Attach rules to local ids]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Find the rules for locally-defined Ids; then we can attach them
to the binders in the top-level bindings

Reason
  - It makes the rules easier to look up
  - It means that transformation rules and specialisations for
    locally defined Ids are handled uniformly
  - It keeps alive things that are referred to only from a rule
    (the occurrence analyser knows about rules attached to Ids)
  - It makes sure that, when we apply a rule, the free vars
    of the RHS are more likely to be in scope
  - The imported rules are carried in the in-scope set
    which is extended on each iteration by the new wave of
    local binders; any rules which aren't on the binding will
    thereby get dropped

349

Austin Seipp's avatar
Austin Seipp committed
350 351 352 353 354 355
************************************************************************
*                                                                      *
*              Desugaring transformation rules
*                                                                      *
************************************************************************
-}
356

Simon Marlow's avatar
Simon Marlow committed
357
dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
358
dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))
359
  = putSrcSpanDs loc $
360
    do  { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars]
361

ian@well-typed.com's avatar
ian@well-typed.com committed
362
        ; lhs' <- unsetGOptM Opt_EnableRewriteRules $
363
                  unsetWOptM Opt_WarnIdentities $
364
                  dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
365

366
        ; rhs' <- dsLExpr rhs
367
        ; this_mod <- getModule
368

369 370
        ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'

371 372
        -- Substitute the dict bindings eagerly,
        -- and take the body apart into a (f args) form
373
        ; case decomposeRuleLhs bndrs'' lhs'' of {
374 375 376 377 378 379 380 381
                Left msg -> do { warnDs msg; return Nothing } ;
                Right (final_bndrs, fn_id, args) -> do

        { let is_local = isLocalId fn_id
                -- NB: isLocalId is False of implicit Ids.  This is good because
                -- we don't want to attach rules to the bindings of implicit Ids,
                -- because they don't show up in the bindings until just before code gen
              fn_name   = idName fn_id
382
              final_rhs = simpleOptExpr rhs''    -- De-crap it
383
              rule_name = snd (unLoc name)
384
              rule      = mkRule this_mod False {- Not auto -} is_local
385
                                 rule_name rule_act fn_name final_bndrs args
386
                                 final_rhs
387 388 389 390 391
              arg_ids = varSetElems (exprsSomeFreeVars isId args `delVarSetList` final_bndrs)

        ; dflags <- getDynFlags
        ; when (wopt Opt_WarnInlineRuleShadowing dflags) $
          warnRuleShadowing rule_name rule_act fn_id arg_ids
392

393 394 395 396 397 398 399 400 401 402 403 404 405 406
        ; return (Just rule)
        } } }


warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
-- See Note [Rules and inlining/other rules]
warnRuleShadowing rule_name rule_act fn_id arg_ids
  = do { check False fn_id    -- We often have multiple rules for the same Id in a
                              -- module. Maybe we should check that they don't overlap
                              -- but currently we don't
       ; mapM_ (check True) arg_ids }
  where
    check check_rules_too lhs_id
      | isLocalId lhs_id || canUnfold (idUnfolding lhs_id)
407
                       -- If imported with no unfolding, no worries
408 409
      , idInlineActivation lhs_id `competesWith` rule_act
      = warnDs (vcat [ hang (ptext (sLit "Rule") <+> pprRuleName rule_name
410
                               <+> ptext (sLit "may never fire"))
411
                            2 (ptext (sLit "because") <+> quotes (ppr lhs_id)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
412
                               <+> ptext (sLit "might inline first"))
413
                     , ptext (sLit "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for")
414 415
                       <+> quotes (ppr lhs_id)
                     , ifPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ])
416

417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432
      | check_rules_too
      , bad_rule : _ <- get_bad_rules lhs_id
      = warnDs (vcat [ hang (ptext (sLit "Rule") <+> pprRuleName rule_name
                               <+> ptext (sLit "may never fire"))
                            2 (ptext (sLit "because rule") <+> pprRuleName (ruleName bad_rule)
                               <+> ptext (sLit "for")<+> quotes (ppr lhs_id)
                               <+> ptext (sLit "might fire first"))
                      , ptext (sLit "Probable fix: add phase [n] or [~n] to the competing rule")
                      , ifPprDebug (ppr bad_rule) ])

      | otherwise
      = return ()

    get_bad_rules lhs_id
      = [ rule | rule <- idCoreRules lhs_id
               , ruleActivation rule `competesWith` rule_act ]
433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453

-- See Note [Desugaring coerce as cast]
unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)
unfold_coerce bndrs lhs rhs = do
    (bndrs', wrap) <- go bndrs
    return (bndrs', wrap lhs, wrap rhs)
  where
    go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
    go []     = return ([], id)
    go (v:vs)
        | Just (tc, args) <- splitTyConApp_maybe (idType v)
        , tc == coercibleTyCon = do
            let ty' = mkTyConApp eqReprPrimTyCon args
            v' <- mkDerivedLocalM mkRepEqOcc v ty'

            (bndrs, wrap) <- go vs
            return (v':bndrs, mkCoreLet (NonRec v (mkEqBox (mkCoVarCo v'))) . wrap)
        | otherwise = do
            (bndrs,wrap) <- go vs
            return (v:bndrs, wrap)

454 455
{- Note [Desugaring RULE left hand sides]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
456 457 458 459
For the LHS of a RULE we do *not* want to desugar
    [x]   to    build (\cn. x `c` n)
We want to leave explicit lists simply as chains
of cons's. We can achieve that slightly indirectly by
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
460
switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
461 462

That keeps the desugaring of list comprehensions simple too.
463

464 465


466 467 468
Nor do we want to warn of conversion identities on the LHS;
the rule is precisly to optimise them:
  {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
469

470 471 472 473 474 475 476 477 478 479 480 481 482 483
Note [Desugaring coerce as cast]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want the user to express a rule saying roughly “mapping a coercion over a
list can be replaced by a coercion”. But the cast operator of Core (▷) cannot
be written in Haskell. So we use `coerce` for that (#2110). The user writes
    map coerce = coerce
as a RULE, and this optimizes any kind of mapped' casts aways, including `map
MkNewtype`.

For that we replace any forall'ed `c :: Coercible a b` value in a RULE by
corresponding `co :: a ~#R b` and wrap the LHS and the RHS in
`let c = MkCoercible co in ...`. This is later simplified to the desired form
by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).

484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519
Note [Rules and inlining/other rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If you have
  f x = ...
  g x = ...
  {-# RULES "rule-for-f" forall x. f (g x) = ... #-}
then there's a good chance that in a potential rule redex
    ...f (g e)...
then 'f' or 'g' will inline befor the rule can fire.  Solution: add an
INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'.

Note that this applies to all the free variables on the LHS, both the
main function and things in its arguments.

We also check if there are Ids on the LHS that have competing RULES.
In the above example, suppose we had
  {-# RULES "rule-for-g" forally. g [y] = ... #-}
Then "rule-for-f" and "rule-for-g" would compete.  Better to add phase
control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes
active; or perhpas after "rule-for-g" has become inactive. This is checked
by 'competesWith'

Class methods have a built-in RULE to select the method from the dictionary,
so you can't change the phase on this.  That makes id very dubious to
match on class methods in RULE lhs's.   See Trac #10595.   I'm not happy
about this. For exmaple in Control.Arrow we have

{-# RULES "compose/arr"   forall f g .
                          (arr f) . (arr g) = arr (f . g) #-}

and similar, which will elicit exactly these warnings, and risk never
firing.  But it's not clear what to do instead.  We could make the
class methocd rules inactive in phase 2, but that would delay when
subsequent transformations could fire.


Austin Seipp's avatar
Austin Seipp committed
520 521 522 523 524 525
************************************************************************
*                                                                      *
*              Desugaring vectorisation declarations
*                                                                      *
************************************************************************
-}
526 527

dsVect :: LVectDecl Id -> DsM CoreVect
Alan Zimmerman's avatar
Alan Zimmerman committed
528
dsVect (L loc (HsVect _ (L _ v) rhs))
529
  = putSrcSpanDs loc $
530
    do { rhs' <- dsLExpr rhs
531
       ; return $ Vect v rhs'
532
       }
Alan Zimmerman's avatar
Alan Zimmerman committed
533
dsVect (L _loc (HsNoVect _ (L _ v)))
534
  = return $ NoVect v
535
dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
536 537 538 539 540
  = return $ VectType isScalar tycon' rhs_tycon
  where
    tycon' | Just ty <- coreView $ mkTyConTy tycon
           , (tycon', []) <- splitTyConApp ty      = tycon'
           | otherwise                             = tycon
Alan Zimmerman's avatar
Alan Zimmerman committed
541
dsVect vd@(L _ (HsVectTypeIn _ _ _ _))
542
  = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
543 544
dsVect (L _loc (HsVectClassOut cls))
  = return $ VectClass (classTyCon cls)
Alan Zimmerman's avatar
Alan Zimmerman committed
545
dsVect vc@(L _ (HsVectClassIn _ _))
546
  = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)
547 548 549
dsVect (L _loc (HsVectInstOut inst))
  = return $ VectInst (instanceDFunId inst)
dsVect vi@(L _ (HsVectInstIn _))
550
  = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)