[project @ 1996-04-30 17:34:02 by partain]

[ghc-hetmet.git] / ghc / compiler / simplCore / SimplEnv.lhs

diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs
index ed4d11d..ba098ea 100644 (file)
--- a/ghc/compiler/simplCore/SimplEnv.lhs
+++ b/ghc/compiler/simplCore/SimplEnv.lhs
@@ -55,7 +55,7 @@ import CoreUnfold     ( UnfoldingDetails(..), mkGenForm, modifyUnfoldingDetails,
                          calcUnfoldingGuidance, UnfoldingGuidance(..),
                          mkFormSummary, FormSummary
                        )
-import CoreUtils       ( manifestlyWHNF )
+import CoreUtils       ( manifestlyWHNF, exprSmallEnoughToDup )
 import FiniteMap       -- lots of things
 import Id              ( idType, getIdUnfolding, getIdStrictness,
                          applyTypeEnvToId,
@@ -71,7 +71,7 @@ import PprCore                -- various instances
 import PprStyle                ( PprStyle(..) )
 import PprType         ( GenType, GenTyVar )
 import Pretty
-import Type            ( getAppDataTyCon, applyTypeEnvToTy )
+import Type            ( eqTy, getAppDataTyCon, applyTypeEnvToTy )
 import TyVar           ( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv,
                          growTyVarEnvList,
                          TyVarEnv(..), GenTyVar{-instance Eq-}
@@ -80,11 +80,10 @@ import Unique               ( Unique{-instance Outputable-} )
 import UniqFM          ( addToUFM_Directly, lookupUFM_Directly, ufmToList )
 import UniqSet         -- lots of things
 import Usage           ( UVar(..), GenUsage{-instances-} )
-import Util            ( zipEqual, panic, assertPanic )
+import Util            ( zipEqual, panic, panic#, assertPanic )
 
 type TypeEnv = TyVarEnv Type
 cmpType = panic "cmpType (SimplEnv)"
-exprSmallEnoughToDup = panic "exprSmallEnoughToDup (SimplEnv)"
 oneSafeOcc = panic "oneSafeOcc (SimplEnv)"
 oneTextualOcc = panic "oneTextualOcc (SimplEnv)"
 simplIdWantsToBeINLINEd = panic "simplIdWantsToBeINLINEd (SimplEnv)"
@@ -253,7 +252,7 @@ data UnfoldItem -- a glorified triple...
                                        -- we can "wrap" it in the CC
                                        -- that was in force.
 
-data UnfoldConApp -- yet another glorified triple
+data UnfoldConApp -- yet another glorified pair
   = UCA                OutId                   -- same fields as ConForm
                [OutArg]
 
@@ -309,12 +308,12 @@ grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc
   where
     new_con_apps
       = case uf_details of
-         ConForm con vargs
+         ConForm con args
            -> case (lookupFM con_apps entry) of
                 Just _  -> con_apps -- unchanged; we hang onto what we have
                 Nothing -> addToFM con_apps entry id
            where
-             entry = UCA con vargs
+             entry = UCA con args
 
          not_a_constructor -> con_apps -- unchanged
 
@@ -378,7 +377,7 @@ cmp_app (UCA c1 as1) (UCA c2 as2)
   = case (c1 `cmp` c2) of
       LT_ -> LT_
       GT_ -> GT_
-      _   -> cmp_lists cmp_atom as1 as2
+      _   -> cmp_lists cmp_arg as1 as2
   where
     cmp_lists cmp_item []     []     = EQ_
     cmp_lists cmp_item (x:xs) []     = GT_
@@ -386,11 +385,20 @@ cmp_app (UCA c1 as1) (UCA c2 as2)
     cmp_lists cmp_item (x:xs) (y:ys)
       = case cmp_item x y of { EQ_ -> cmp_lists cmp_item xs ys; other -> other }
 
-    cmp_atom (VarArg x) (VarArg y) = x `cmp` y
-    cmp_atom (VarArg _) _               = LT_
-    cmp_atom (LitArg x) (LitArg y)
-      = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
-    cmp_atom (LitArg _) _               = GT_
+    -- ToDo: make an "instance Ord3 CoreArg"???
+
+    cmp_arg (VarArg   x) (VarArg   y) = x `cmp` y
+    cmp_arg (LitArg   x) (LitArg   y) = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
+    cmp_arg (TyArg    x) (TyArg    y) = if x `eqTy` y then EQ_ else panic# "SimplEnv.cmp_app:TyArgs"
+    cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs"
+    cmp_arg x y
+      | tag x _LT_ tag y = LT_
+      | otherwise       = GT_
+      where
+       tag (VarArg   _) = ILIT(1)
+       tag (LitArg   _) = ILIT(2)
+       tag (TyArg    _) = ILIT(3)
+       tag (UsageArg _) = ILIT(4)
 \end{code}
 
 %************************************************************************
@@ -518,7 +526,7 @@ replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 \begin{code}
 extendIdEnvWithAtom
        :: SimplEnv
-       -> InBinder -> OutArg
+       -> InBinder -> OutArg{-Val args only, please-}
        -> SimplEnv
 
 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(LitArg lit)
@@ -542,6 +550,10 @@ extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env)
 
     ok_to_dup    = switchIsOn chkr SimplOkToDupCode
 
+#ifdef DEBUG
+extendIdEnvWithAtom _ _ _ = panic "extendIdEnvWithAtom: non-Val arg!"
+#endif
+
 extendIdEnvWithAtomList
        :: SimplEnv
        -> [(InBinder, OutArg)]