Reject newtypes with strictness annotations; fixes read008

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

diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index 3646f91..7a0d8bc 100644 (file)
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -23,7 +23,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 +32,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 )
@@ -624,7 +624,9 @@ specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
 specExpr subst (Type ty) = returnSM (Type (substTy subst ty), emptyUDs)
 specExpr subst (Var v)   = returnSM (specVar subst v,         emptyUDs)
 specExpr subst (Lit lit) = returnSM (Lit lit,                emptyUDs)
-
+specExpr subst (Cast e co) =
+  specExpr subst e              `thenSM` \ (e', uds) ->
+  returnSM ((Cast e' (substTy subst co)), uds)
 specExpr subst (Note note body)
   = specExpr subst body        `thenSM` \ (body', uds) ->
     returnSM (Note (specNote subst note) body', uds)
@@ -688,7 +690,6 @@ specExpr subst (Let bind body)
     returnSM (foldr Let body' binds', uds)
 
 -- Must apply the type substitution to coerceions
-specNote subst (Coerce t1 t2) = Coerce (substTy subst t1) (substTy subst t2)
 specNote subst note          = note
 \end{code}
 
@@ -1071,10 +1072,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 }
 
@@ -1181,7 +1184,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}