Trim unused imports detected by new unused-import code

[ghc-hetmet.git] / compiler / basicTypes / Id.lhs

diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs
index 74fd2cf..9b595fa 100644 (file)
--- a/compiler/basicTypes/Id.lhs
+++ b/compiler/basicTypes/Id.lhs
@@ -53,12 +53,13 @@ module Id (
        isPrimOpId, isPrimOpId_maybe, 
        isFCallId, isFCallId_maybe,
        isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon,
-       isBottomingId, idIsFrom,
+        isConLikeId, isBottomingId, idIsFrom,
         isTickBoxOp, isTickBoxOp_maybe,
        hasNoBinding, 
 
        -- ** Inline pragma stuff
-       idInlinePragma, setInlinePragma, modifyInlinePragma, 
+       idInlinePragma, setInlinePragma, modifyInlinePragma,
+        idInlineActivation, setInlineActivation, idRuleMatchInfo,
 
        -- ** One-shot lambdas
        isOneShotBndr, isOneShotLambda, isStateHackType,
@@ -106,7 +107,7 @@ import IdInfo
 import BasicTypes
 
 -- Imported and re-exported 
-import Var( Id, DictId,
+import Var( Var, Id, DictId,
             idInfo, idDetails, globaliseId,
             isId, isLocalId, isGlobalId, isExportedId )
 import qualified Var
@@ -125,13 +126,13 @@ import Module
 import Class
 import PrimOp
 import ForeignCall
-import OccName
 import Maybes
 import SrcLoc
 import Outputable
 import Unique
 import UniqSupply
 import FastString
+import Util( count )
 import StaticFlags
 
 -- infixl so you can say (id `set` a `set` b)
@@ -598,14 +599,26 @@ The inline pragma tells us to be very keen to inline this Id, but it's still
 OK not to if optimisation is switched off.
 
 \begin{code}
-idInlinePragma :: Id -> InlinePragInfo
+idInlinePragma :: Id -> InlinePragma
 idInlinePragma id = inlinePragInfo (idInfo id)
 
-setInlinePragma :: Id -> InlinePragInfo -> Id
+setInlinePragma :: Id -> InlinePragma -> Id
 setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id
 
-modifyInlinePragma :: Id -> (InlinePragInfo -> InlinePragInfo) -> Id
+modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id
 modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id
+
+idInlineActivation :: Id -> Activation
+idInlineActivation id = inlinePragmaActivation (idInlinePragma id)
+
+setInlineActivation :: Id -> Activation -> Id
+setInlineActivation id act = modifyInlinePragma id (\(InlinePragma _ match_info) -> InlinePragma act match_info)
+
+idRuleMatchInfo :: Id -> RuleMatchInfo
+idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id)
+
+isConLikeId :: Id -> Bool
+isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id)
 \end{code}
 
 
@@ -697,23 +710,47 @@ where g has interesting strictness information.  Then if we float thus
    g' = /\a. rhs
    f = /\a. ...[g' a/g]
 
-we *do not* want to lose the strictness information on g.  Nor arity.
+we *do not* want to lose g's
+  * strictness information
+  * arity 
+  * inline pragma (though that is bit more debatable)
 
 It's simple to retain strictness and arity, but not so simple to retain
-       worker info
-       rules
+  * worker info
+  * rules
 so we simply discard those.  Sooner or later this may bite us.
 
 This transfer is used in two places: 
        FloatOut (long-distance let-floating)
        SimplUtils.abstractFloats (short-distance let-floating)
 
+If we abstract wrt one or more *value* binders, we must modify the 
+arity and strictness info before transferring it.  E.g. 
+      f = \x. e
+-->
+      g' = \y. \x. e
+      + substitute (g' y) for g
+Notice that g' has an arity one more than the original g
+
 \begin{code}
-transferPolyIdInfo :: Id -> Id -> Id
-transferPolyIdInfo old_id new_id
+transferPolyIdInfo :: Id       -- Original Id
+                  -> [Var]     -- Abstract wrt these variables
+                  -> Id        -- New Id
+                  -> Id
+transferPolyIdInfo old_id abstract_wrt new_id
   = modifyIdInfo transfer new_id
   where
-    old_info = idInfo old_id
-    transfer new_info = new_info `setNewStrictnessInfo` (newStrictnessInfo old_info)
-                                `setArityInfo` (arityInfo old_info)
+    arity_increase = count isId abstract_wrt   -- Arity increases by the
+                                               -- number of value binders
+
+    old_info       = idInfo old_id
+    old_arity       = arityInfo old_info
+    old_inline_prag = inlinePragInfo old_info
+    new_arity       = old_arity + arity_increase
+    old_strictness  = newStrictnessInfo old_info
+    new_strictness  = fmap (increaseStrictSigArity arity_increase) old_strictness
+
+    transfer new_info = new_info `setNewStrictnessInfo` new_strictness
+                                `setArityInfo` new_arity
+                                `setInlinePragInfo` old_inline_prag
 \end{code}