[project @ 1998-03-09 17:26:31 by simonpj]

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

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 7997378..03ee2bd 100644 (file)
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -4,10 +4,10 @@
 \section[SimplUtils]{The simplifier utilities}
 
 \begin{code}
-#include "HsVersions.h"
-
 module SimplUtils (
 
+       newId, newIds,
+
        floatExposesHNF,
 
        etaCoreExpr, mkRhsTyLam,
@@ -19,18 +19,16 @@ module SimplUtils (
        singleConstructorType, typeOkForCase
     ) where
 
-IMP_Ubiq(){-uitous-}
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER(SmplLoop)              -- paranoia checking
-#endif
+#include "HsVersions.h"
 
 import BinderInfo
 import CmdLineOpts     ( opt_DoEtaReduction, SimplifierSwitch(..) )
 import CoreSyn
 import CoreUnfold      ( SimpleUnfolding, mkFormSummary, exprIsTrivial, FormSummary(..) )
-import Id              ( idType, isBottomingId, addInlinePragma, addIdDemandInfo,
-                         idWantsToBeINLINEd, dataConArgTys, SYN_IE(Id),
-                         getIdArity, GenId{-instance Eq-}
+import Id              ( idType, isBottomingId, mkSysLocal,
+                         addInlinePragma, addIdDemandInfo,
+                         idWantsToBeINLINEd, dataConArgTys, Id,
+                         getIdArity,
                        )
 import IdInfo          ( ArityInfo(..), DemandInfo )
 import Maybes          ( maybeToBool )
@@ -38,19 +36,44 @@ import PrelVals             ( augmentId, buildId )
 import PrimOp          ( primOpIsCheap )
 import SimplEnv
 import SimplMonad
-import Type            ( tyVarsOfType, mkForAllTys, mkTyVarTys, isPrimType, getTyVar_maybe,
-                         maybeAppDataTyConExpandingDicts, SYN_IE(Type)
+import Type            ( tyVarsOfType, mkForAllTys, mkTyVarTys, getTyVar_maybe,
+                         splitAlgTyConApp_maybe, Type
                        )
 import TyCon           ( isDataTyCon )
-import TyVar           ( elementOfTyVarSet,
-                         GenTyVar{-instance Eq-} )
-import Util            ( isIn, panic, assertPanic )
+import TyVar           ( elementOfTyVarSet )
+import SrcLoc          ( noSrcLoc )
+import Util            ( isIn, zipWithEqual, panic, assertPanic )
 
 \end{code}
 
 
-Floating
-~~~~~~~~
+%************************************************************************
+%*                                                                     *
+\subsection{New ids}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+newId :: Type -> SmplM Id
+newId ty
+  = getUniqueSmpl     `thenSmpl`  \ uniq ->
+    returnSmpl (mkSysLocal SLIT("s") uniq ty noSrcLoc)
+
+newIds :: [Type] -> SmplM [Id]
+newIds tys
+  = getUniquesSmpl (length tys)    `thenSmpl`  \ uniqs ->
+    returnSmpl (zipWithEqual "newIds" mk_id tys uniqs)
+  where
+    mk_id ty uniq = mkSysLocal SLIT("s") uniq ty noSrcLoc
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
+\subsection{Floating}
+%*                                                                     *
+%************************************************************************
+
 The function @floatExposesHNF@ tells whether let/case floating will
 expose a head normal form.  It is passed booleans indicating the
 desired strategy.
@@ -60,7 +83,7 @@ floatExposesHNF
        :: Bool                 -- Float let(rec)s out of rhs
        -> Bool                 -- Float cheap primops out of rhs
        -> Bool                 -- OK to duplicate code
-       -> GenCoreExpr bdr Id tyvar uvar
+       -> GenCoreExpr bdr Id flexi
        -> Bool
 
 floatExposesHNF float_lets float_primops ok_to_dup rhs
@@ -320,7 +343,7 @@ arguments as you care to give it.  For this special case we return
 100, to represent "infinity", which is a bit of a hack.
 
 \begin{code}
-etaExpandCount :: GenCoreExpr bdr Id tyvar uvar
+etaExpandCount :: GenCoreExpr bdr Id flexi
               -> Int   -- Number of extra args you can safely abstract
 
 etaExpandCount (Lam (ValBinder _) body)
@@ -349,7 +372,7 @@ etaExpandCount other = 0    -- Give up
        -- Case with non-whnf scrutinee
 
 -----------------------------
-eta_fun :: GenCoreExpr bdr Id tv uv -- The function
+eta_fun :: GenCoreExpr bdr Id flexi -- The function
        -> Int                      -- How many args it can safely be applied to
 
 eta_fun (App fun arg) | notValArg arg = eta_fun fun
@@ -384,7 +407,7 @@ which aren't WHNF but are ``cheap'' are:
        where op is a cheap primitive operator
 
 \begin{code}
-manifestlyCheap :: GenCoreExpr bndr Id tv uv -> Bool
+manifestlyCheap :: GenCoreExpr bndr Id flexi -> Bool
 
 manifestlyCheap (Var _)        = True
 manifestlyCheap (Lit _)        = True
@@ -401,7 +424,7 @@ manifestlyCheap (Case scrut alts)
   = manifestlyCheap scrut && all manifestlyCheap (rhssOfAlts alts)
 
 manifestlyCheap other_expr   -- look for manifest partial application
-  = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
+  = case (collectArgs other_expr) of { (fun, _, vargs) ->
     case fun of
 
       Var f | isBottomingId f -> True  -- Application of a function which
@@ -458,13 +481,13 @@ idMinArity id = case getIdArity id of
 
 singleConstructorType :: Type -> Bool
 singleConstructorType ty
-  = case (maybeAppDataTyConExpandingDicts ty) of
+  = case (splitAlgTyConApp_maybe ty) of
       Just (tycon, ty_args, [con]) | isDataTyCon tycon -> True
       other                                           -> False
 
 typeOkForCase :: Type -> Bool
 typeOkForCase ty
-  = case (maybeAppDataTyConExpandingDicts ty) of
+  = case (splitAlgTyConApp_maybe ty) of
       Just (tycon, ty_args, [])                                    -> False
       Just (tycon, ty_args, non_null_data_cons) | isDataTyCon tycon -> True
       other                                                        -> False