Patch for shared libraries support on FreeBSD

[ghc-hetmet.git] / compiler / deSugar / DsBinds.lhs

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 3fe8d54..f6fc5a3 100644 (file)
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -322,7 +322,7 @@ makeCorePair gbl_id arity rhs
   | isInlinePragma (idInlinePragma gbl_id)
        -- Add an Unfolding for an INLINE (but not for NOINLINE)
        -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
-  = (gbl_id `setIdUnfolding` mkInlineRule InlSat rhs arity,
+  = (gbl_id `setIdUnfolding` mkInlineRule needSaturated rhs arity,
      etaExpand arity rhs)
   | otherwise
   = (gbl_id, rhs)
@@ -397,6 +397,40 @@ gotten from the binding for fromT_1.
 It might be better to have just one level of AbsBinds, but that requires more
 thought!
 
+Note [Implementing SPECIALISE pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Example:
+       f :: (Eq a, Ix b) => a -> b -> Bool
+       {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
+
+From this the typechecker generates
+
+    AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
+
+    SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
+                      -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
+
+Note that wrap_fn can transform *any* function with the right type prefix 
+    forall ab. (Eq a, Ix b) => <blah>
+regardless of <blah>.  It's sort of polymorphic in <blah>.  This is
+useful: we use the same wrapper to transform each of the class ops, as
+well as the dict.
+
+From these we generate:
+
+    Rule:      forall p, q, (dp:Ix p), (dq:Ix q). 
+                    f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
+
+    Spec bind: f_spec = wrap_fn (/\ab \d1 d2. Let binds in f_mono)
+
+Note that 
+
+  * The LHS of the rule may mention dictionary *expressions* (eg
+    $dfIxPair dp dq), and that is essential because the dp, dq are
+    needed on the RHS.
+
+  * The RHS of f_spec has a *copy* of 'binds', so that it can fully
+    specialise it.
 
 \begin{code}
 ------------------------
@@ -405,30 +439,7 @@ dsSpecs :: [TyVar] -> [DictId] -> [TyVar]
         -> CoreBind -> [LSpecPrag]
         -> DsM ( [(Id,CoreExpr)]       -- Binding for specialised Ids
               , [CoreRule] )           -- Rules for the Global Ids
--- Example:
---     f :: (Eq a, Ix b) => a -> b -> b
---     {-# SPECIALISE f :: Ix b => Int -> b -> b #-}
---
---     AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
--- 
---     SpecPrag (/\b.\(d:Ix b). f Int b dInt d) 
---              (forall b. Ix b => Int -> b -> b)
---
--- Rule:       forall b,(d:Ix b). f Int b dInt d = f_spec b d
---
--- Spec bind:  f_spec = Let f = /\ab \(d1:Eq a)(d2:Ix b). let binds in f_mono 
---                      /\b.\(d:Ix b). in f Int b dInt d
---             The idea is that f occurs just once, so it'll be 
---             inlined and specialised
---
--- Given SpecPrag (/\as.\ds. f es) t, we have
--- the defn            f_spec as ds = let-nonrec f = /\fas\fds. let f_mono = <f-rhs> in f_mono
---                                    in f es 
--- and the RULE                forall as, ds. f es = f_spec as ds
---
--- It is *possible* that 'es' does not mention all of the dictionaries 'ds'
--- (a bit silly, because then the 
-
+-- See Note [Implementing SPECIALISE pragmas]
 dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags
   = do { pairs <- mapMaybeM spec_one prags
        ; let (spec_binds_s, rules) = unzip pairs
@@ -452,7 +463,7 @@ dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags
                bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing } 
                   | otherwise -> do
 
-          { (spec_unf, unf_pairs) <- specUnfolding wrap_fn (idUnfolding poly_id)
+          { (spec_unf, unf_pairs) <- specUnfolding wrap_fn (realIdUnfolding poly_id)
 
           ; let f_body = fix_up (Let mono_bind (Var mono_id))
                  spec_ty = exprType ds_spec_expr
@@ -467,8 +478,8 @@ dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags
                 spec_id_arity = inl_arity + count isDictId bndrs
 
                 extra_dict_bndrs = [ localiseId d  -- See Note [Constant rule dicts]
-                                        | d <- varSetElems (exprFreeVars ds_spec_expr)
-                                        , isDictId d]
+                                   | d <- varSetElems (exprFreeVars ds_spec_expr)
+                                   , isDictId d]
                                -- Note [Const rule dicts]
 
                 rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))