--Standard modules
import qualified Maybe
-import System.IO.Unsafe
+import qualified System.IO.Unsafe
-- GHC API
import qualified GHC
import qualified TcType
import qualified HsExpr
import qualified HsTypes
-import qualified HsBinds
import qualified HscTypes
-import qualified RdrName
import qualified Name
-import qualified OccName
-import qualified Type
import qualified Id
import qualified TyCon
import qualified DataCon
import qualified TysWiredIn
-import qualified Bag
import qualified DynFlags
import qualified SrcLoc
import qualified CoreSyn
import qualified Var
import qualified IdInfo
import qualified VarSet
-import qualified Unique
import qualified CoreUtils
import qualified CoreFVs
import qualified Literal
normalise_tfp_int :: HscTypes.HscEnv -> Type.Type -> Type.Type
normalise_tfp_int env ty =
- unsafePerformIO $ do
- nty <- normaliseType env ty
- return nty
+ System.IO.Unsafe.unsafePerformIO $
+ normaliseType env ty
-- | Get the width of a SizedWord type
-- sized_word_len :: HscTypes.HscEnv -> Type.Type -> Int
has_free_tyvars :: CoreSyn.CoreExpr -> Bool
has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)
+-- Does the given type have any free type vars?
+ty_has_free_tyvars :: Type.Type -> Bool
+ty_has_free_tyvars = not . VarSet.isEmptyVarSet . Type.tyVarsOfType
+
-- Does the given CoreExpr have any free local vars?
has_free_vars :: CoreSyn.CoreExpr -> Bool
has_free_vars = not . VarSet.isEmptyVarSet . CoreFVs.exprFreeVars
-- arguments, to get at the value arguments.
n = length tyvars + length predtypes
-getLiterals :: CoreSyn.CoreExpr -> [CoreSyn.CoreExpr]
-getLiterals app@(CoreSyn.App _ _) = literals
+getLiterals :: HscTypes.HscEnv -> CoreSyn.CoreExpr -> [CoreSyn.CoreExpr]
+getLiterals _ app@(CoreSyn.App _ _) = literals
where
(CoreSyn.Var f, args) = CoreSyn.collectArgs app
literals = filter (is_lit) args
-getLiterals lit@(CoreSyn.Lit _) = [lit]
+getLiterals _ lit@(CoreSyn.Lit _) = [lit]
+
+getLiterals hscenv letrec@(CoreSyn.Let (CoreSyn.NonRec letBind (letExpr)) letRes) = [lit]
+ where
+ ty = Var.varType letBind
+ litInt = eval_tfp_int hscenv ty
+ lit = CoreSyn.Lit (Literal.mkMachInt (toInteger litInt))
+
+getLiterals _ expr = error $ "\nCoreTools.getLiterals: Not a known Lit: " ++ pprString expr
reduceCoreListToHsList ::
[HscTypes.CoreModule] -- ^ The modules where parts of the list are hidden
-- Is the given var the State data constructor?
isStateCon :: Var.Var -> Bool
-isStateCon var = do
+isStateCon var =
-- See if it is a DataConWrapId (not DataConWorkId, since State is a
-- newtype).
case Id.idDetails var of
genUniques' subst (CoreSyn.Let (CoreSyn.Rec binds) res) = do
-- Make each of the binders unique
(subst', bndrs') <- mapAccumLM genUnique subst (map fst binds)
- bounds' <- mapM (genUniques' subst') (map snd binds)
+ bounds' <- mapM (genUniques' subst' . snd) binds
res' <- genUniques' subst' res
let binds' = zip bndrs' bounds'
return $ CoreSyn.Let (CoreSyn.Rec binds') res'