Add {-# OPTIONS_GHC -w #-} and some blurb to all compiler modules

[ghc-hetmet.git] / compiler / specialise / Specialise.lhs

diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index fa9d253..bb47a97 100644 (file)
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -4,6 +4,13 @@
 \section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
 
 \begin{code}
+{-# OPTIONS_GHC -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+-- for details
+
 module Specialise ( specProgram ) where
 
 #include "HsVersions.h"
@@ -23,7 +30,7 @@ import VarSet
 import VarEnv
 import CoreSyn
 import CoreUtils       ( applyTypeToArgs, mkPiTypes )
-import CoreFVs         ( exprFreeVars, exprsFreeVars, idRuleVars )
+import CoreFVs         ( exprFreeVars, exprsFreeVars, idFreeVars )
 import CoreTidy                ( tidyRules )
 import CoreLint                ( showPass, endPass )
 import Rules           ( addIdSpecialisations, mkLocalRule, lookupRule, emptyRuleBase, rulesOfBinds )
@@ -32,7 +39,7 @@ import UniqSupply     ( UniqSupply,
                          UniqSM, initUs_, thenUs, returnUs, getUniqueUs, 
                          getUs, mapUs
                        )
-import Name            ( nameOccName, mkSpecOcc, getSrcLoc )
+import Name
 import MkId            ( voidArgId, realWorldPrimId )
 import FiniteMap
 import Maybes          ( catMaybes, maybeToBool )
@@ -783,8 +790,8 @@ specDefn :: Subst                   -- Subst to use for RHS
 
 specDefn subst calls (fn, rhs)
        -- The first case is the interesting one
-  |  rhs_tyvars `lengthIs` n_tyvars    -- Rhs of fn's defn has right number of big lambdas
-  && rhs_bndrs  `lengthAtLeast` n_dicts        -- and enough dict args
+  |  rhs_tyvars `lengthIs`     n_tyvars -- Rhs of fn's defn has right number of big lambdas
+  && rhs_ids    `lengthAtLeast` n_dicts        -- and enough dict args
   && notNull calls_for_me              -- And there are some calls to specialise
 
 --   && not (certainlyWillInline (idUnfolding fn))     -- And it's not small
@@ -806,7 +813,9 @@ specDefn subst calls (fn, rhs)
              rhs_uds `plusUDs` plusUDList spec_uds)
 
   | otherwise  -- No calls or RHS doesn't fit our preconceptions
-  = specExpr subst rhs                 `thenSM` \ (rhs', rhs_uds) ->
+  = WARN( notNull calls_for_me, ptext SLIT("Missed specialisation opportunity for") <+> ppr fn )
+         -- Note [Specialisation shape]
+    specExpr subst rhs                 `thenSM` \ (rhs', rhs_uds) ->
     returnSM ((fn, rhs'), [], rhs_uds)
   
   where
@@ -898,10 +907,42 @@ specDefn subst calls (fn, rhs)
 
       where
        my_zipEqual doc xs ys 
-        | not (equalLength xs ys) = pprPanic "my_zipEqual" (ppr xs $$ ppr ys $$ (ppr fn <+> ppr call_ts) $$ ppr rhs)
+#ifdef DEBUG
+        | not (equalLength xs ys) = pprPanic "my_zipEqual" (vcat 
+                                               [ ppr xs, ppr ys
+                                               , ppr fn <+> ppr call_ts
+                                               , ppr (idType fn), ppr theta
+                                               , ppr n_dicts, ppr rhs_dicts 
+                                               , ppr rhs])
+#endif
         | otherwise               = zipEqual doc xs ys
 \end{code}
 
+Note [Specialisation shape]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We only specialise a function if it has visible top-level lambdas
+corresponding to its overloading.  E.g. if
+       f :: forall a. Eq a => ....
+then its body must look like
+       f = /\a. \d. ...
+
+Reason: when specialising the body for a call (f ty dexp), we want to
+substitute dexp for d, and pick up specialised calls in the body of f.
+
+This doesn't always work.  One example I came across was htis:
+       newtype Gen a = MkGen{ unGen :: Int -> a }
+
+       choose :: Eq a => a -> Gen a
+       choose n = MkGen (\r -> n)
+
+       oneof = choose (1::Int)
+
+It's a silly exapmle, but we get
+       choose = /\a. g `cast` co
+where choose doesn't have any dict arguments.  Thus far I have not
+tried to fix this (wait till there's a real example).
+
+
 Note [Inline specialisations]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We transfer to the specialised function any INLINE stuff from the
@@ -1072,10 +1113,12 @@ bind_fvs (Rec prs)         = foldl delVarSet rhs_fvs bndrs
                             bndrs = map fst prs
                             rhs_fvs = unionVarSets (map pair_fvs prs)
 
-pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idRuleVars bndr
+pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idFreeVars bndr
        -- Don't forget variables mentioned in the
        -- rules of the bndr.  C.f. OccAnal.addRuleUsage
-
+       -- Also tyvars mentioned in its type; they may not appear in the RHS
+       --      type T a = Int
+       --      x :: T a = 3
 
 addDictBind (dict,rhs) uds = uds { dict_binds = mkDB (NonRec dict rhs) `consBag` dict_binds uds }
 
@@ -1182,7 +1225,7 @@ newIdSM old_id new_ty
     let 
        -- Give the new Id a similar occurrence name to the old one
        name   = idName old_id
-       new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcLoc name)
+       new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcSpan name)
     in
     returnSM new_id
 \end{code}