Merge remote-tracking branch 'origin/master' into type-nats
[ghc.git] / compiler / deSugar / DsBinds.lhs
index 7ff5e69..8fc6bd9 100644 (file)
@@ -32,7 +32,8 @@ import DsUtils
 
 import HsSyn           -- lots of things
 import CoreSyn         -- lots of things
-import HscTypes(MonadThings)
+import HscTypes         ( MonadThings )
+import Literal          ( Literal(MachStr) )
 import CoreSubst
 import MkCore
 import CoreUtils
@@ -41,6 +42,7 @@ import CoreUnfold
 import CoreFVs
 import Digraph
 
+
 import TyCon      ( isTupleTyCon, tyConDataCons_maybe )
 import TcEvidence
 import TcType
@@ -50,7 +52,7 @@ import TysWiredIn ( eqBoxDataCon, tupleCon )
 import Id
 import Class
 import DataCon ( dataConWorkId )
-import Name    ( localiseName )
+import Name    ( Name, localiseName )
 import MkId    ( seqId )
 import Var
 import VarSet
@@ -62,9 +64,11 @@ import Maybes
 import OrdList
 import Bag
 import BasicTypes hiding ( TopLevel )
+import DynFlags
 import FastString
+import ErrUtils( MsgDoc )
 import Util
-
+import Control.Monad( when )
 import MonadUtils
 import Control.Monad(liftM)
 \end{code}
@@ -152,18 +156,20 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
 dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
                    , abs_exports = exports, abs_ev_binds = ev_binds
                    , abs_binds = binds })
+         -- See Note [Desugaring AbsBinds]
   = do  { bind_prs    <- ds_lhs_binds binds
-        ; ds_binds    <- dsTcEvBinds ev_binds
-        ; let core_bind = Rec (fromOL bind_prs)
+        ; let core_bind = Rec [ makeCorePair (add_inline lcl_id) False 0 rhs
+                              | (lcl_id, rhs) <- fromOL bind_prs ]
                -- Monomorphic recursion possible, hence Rec
 
+             locals       = map abe_mono exports
              tup_expr     = mkBigCoreVarTup locals
              tup_ty       = exprType tup_expr
-             poly_tup_rhs = mkLams tyvars $ mkLams dicts $
+        ; ds_binds <- dsTcEvBinds ev_binds
+       ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
                             mkCoreLets ds_binds $
                             Let core_bind $
                             tup_expr
-             locals       = map abe_mono exports
 
        ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
 
@@ -176,13 +182,28 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
                                 mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
                      ; let rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
                     ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
-                    ; let global' = addIdSpecialisations global rules
+                    ; let global' = (global `setInlinePragma` defaultInlinePragma)
+                                             `addIdSpecialisations` rules
+                           -- Kill the INLINE pragma because it applies to
+                           -- the user written (local) function.  The global
+                           -- Id is just the selector.  Hmm.  
                     ; return ((global', rhs) `consOL` spec_binds) }
 
         ; export_binds_s <- mapM mk_bind exports
 
        ; return ((poly_tup_id, poly_tup_rhs) `consOL` 
                    concatOL export_binds_s) }
+  where
+    inline_env :: IdEnv Id   -- Maps a monomorphic local Id to one with
+                             -- the inline pragma from the source
+                             -- The type checker put the inline pragma
+                             -- on the *global* Id, so we need to transfer it
+    inline_env = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)
+                          | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports
+                          , let prag = idInlinePragma gbl_id ]
+
+    add_inline :: Id -> Id    -- tran
+    add_inline lcl_id = lookupVarEnv inline_env lcl_id `orElse` lcl_id
 
 ------------------------
 makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
@@ -219,6 +240,16 @@ dictArity :: [Var] -> Arity
 dictArity dicts = count isId dicts
 \end{code}
 
+[Desugaring AbsBinds]
+~~~~~~~~~~~~~~~~~~~~~
+In the general AbsBinds case we desugar the binding to this:
+
+       tup a (d:Num a) = let fm = ...gm...
+                             gm = ...fm...
+                         in (fm,gm)
+       f a d = case tup a d of { (fm,gm) -> fm }
+       g a d = case tup a d of { (fm,gm) -> fm }
+
 Note [Rules and inlining]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 Common special case: no type or dictionary abstraction
@@ -399,6 +430,13 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
                                    -- Moreover, classops don't (currently) have an inl_sat arity set
                            -- (it would be Just 0) and that in turn makes makeCorePair bleat
 
+  | no_act_spec && isNeverActive rule_act 
+  = putSrcSpanDs loc $ 
+    do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for NOINLINE function:")
+                 <+> quotes (ppr poly_id))
+       ; return Nothing  }  -- Function is NOINLINE, and the specialiation inherits that
+                                   -- See Note [Activation pragmas for SPECIALISE]
+
   | otherwise
   = putSrcSpanDs loc $ 
     do { let poly_name = idName poly_id
@@ -415,28 +453,6 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
        ; let spec_id  = mkLocalId spec_name spec_ty 
                            `setInlinePragma` inl_prag
                            `setIdUnfolding`  spec_unf
-             id_inl = idInlinePragma poly_id
-
-            -- See Note [Activation pragmas for SPECIALISE]
-             inl_prag | not (isDefaultInlinePragma spec_inl)    = spec_inl
-                     | not is_local_id  -- See Note [Specialising imported functions]
-                                        -- in OccurAnal
-                      , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
-                     | otherwise                               = id_inl
-                     -- Get the INLINE pragma from SPECIALISE declaration, or,
-              -- failing that, from the original Id
-
-             spec_prag_act = inlinePragmaActivation spec_inl
-
-            -- See Note [Activation pragmas for SPECIALISE]
-            -- no_act_spec is True if the user didn't write an explicit
-            -- phase specification in the SPECIALISE pragma
-             no_act_spec = case inlinePragmaSpec spec_inl of
-                             NoInline -> isNeverActive  spec_prag_act
-                             _        -> isAlwaysActive spec_prag_act
-            rule_act | no_act_spec = inlinePragmaActivation id_inl   -- Inherit
-                      | otherwise   = spec_prag_act                   -- Specified by user
-
              rule =  mkRule False {- Not auto -} is_local_id
                         (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
                                rule_act poly_name
@@ -446,6 +462,9 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
        ; spec_rhs <- dsHsWrapper spec_co poly_rhs
        ; let spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
 
+       ; dflags <- getDynFlags
+       ; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags)
+              (warnDs (specOnInline poly_name))
        ; return (Just (spec_pair `consOL` unf_pairs, rule))
        } } }
   where
@@ -460,6 +479,29 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
              | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
                            -- The type checker has checked that it *has* an unfolding
 
+    id_inl = idInlinePragma poly_id
+
+    -- See Note [Activation pragmas for SPECIALISE]
+    inl_prag | not (isDefaultInlinePragma spec_inl)    = spec_inl
+             | not is_local_id  -- See Note [Specialising imported functions]
+                                -- in OccurAnal
+             , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
+             | otherwise                               = id_inl
+     -- Get the INLINE pragma from SPECIALISE declaration, or,
+     -- failing that, from the original Id
+
+    spec_prag_act = inlinePragmaActivation spec_inl
+
+    -- See Note [Activation pragmas for SPECIALISE]
+    -- no_act_spec is True if the user didn't write an explicit
+    -- phase specification in the SPECIALISE pragma
+    no_act_spec = case inlinePragmaSpec spec_inl of
+                    NoInline -> isNeverActive  spec_prag_act
+                    _        -> isAlwaysActive spec_prag_act
+    rule_act | no_act_spec = inlinePragmaActivation id_inl   -- Inherit
+             | otherwise   = spec_prag_act                   -- Specified by user
+
+
 specUnfolding :: HsWrapper -> Type 
               -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
 {-   [Dec 10: TEMPORARILY commented out, until we can straighten out how to
@@ -472,6 +514,10 @@ specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
 -}
 specUnfolding _ _ _
   = return (noUnfolding, nilOL)
+
+specOnInline :: Name -> MsgDoc
+specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:") 
+                 <+> quotes (ppr f)
 \end{code}
 
 
@@ -712,14 +758,21 @@ dsEvTerm (EvSuperClass d n)
   = return $ Var sc_sel_id `mkTyApps` tys `App` Var d
   where
     sc_sel_id  = classSCSelId cls n    -- Zero-indexed
-    (cls, tys) = getClassPredTys (evVarPred d)    
+    (cls, tys) = getClassPredTys (evVarPred d)   
+dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
+  where 
+    errorId = rUNTIME_ERROR_ID
+    litMsg  = Lit (MachStr msg)
 
-dsEvTerm (EvInteger n) = mkIntegerExpr n
+dsEvTerm (EvLit l) =
+  case l of
+    EvNum n -> mkIntegerExpr n
+    EvStr s -> mkStringExprFS s
 
 ---------------------------------------
 dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr
 -- This is the crucial function that moves 
--- from LCoercions to Coercions; see Note [TcCoercions] in Coercion
+-- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion
 -- e.g.  dsTcCoercion (trans g1 g2) k
 --       = case g1 of EqBox g1# ->
 --         case g2 of EqBox g2# ->