Commit 2ef5cd26 authored by Ian Lynagh's avatar Ian Lynagh

Put the Integer type, rather than the mkIntegerId, inside LitInteger

This will make it possible to write PrelRules that produce an Integer
result without having Integer arguments.
parent c7c44288
......@@ -52,9 +52,7 @@ module Literal
import TysPrim
import PrelNames
import Type
import TypeRep
import TyCon
import Var
import Outputable
import FastTypes
import FastString
......@@ -122,32 +120,27 @@ data Literal
-- @stdcall@ labels. @Just x@ => @\<x\>@ will
-- be appended to label name when emitting assembly.
| LitInteger Integer Id -- ^ Integer literals
-- See Note [Integer literals]
| LitInteger Integer Type -- ^ Integer literals
-- See Note [Integer literals]
deriving (Data, Typeable)
\end{code}
Note [Integer literals]
~~~~~~~~~~~~~~~~~~~~~~~
An Integer literal is represented using, well, an Integer, to make it
easier to write RULEs for them.
easier to write RULEs for them. They also contain the Integer type, so
that e.g. literalType can return the right Type for them.
* The Id is for mkInteger, which we use when finally creating the core.
They only get converted into real Core,
mkInteger [c1, c2, .., cn]
during the CorePrep phase, although TidyPgm looks ahead at what the
core will be, so that it can see whether it involves CAFs.
* They only get converted into real Core,
mkInteger [c1, c2, .., cn]
during the CorePrep phase.
* When we initally build an Integer literal, notably when
deserialising it from an interface file (see the Binary instance
below), we don't have convenient access to the mkInteger Id. So we
just use an error thunk, and fill in the real Id when we do tcIfaceLit
in TcIface.
* When looking for CAF-hood (in TidyPgm), we must take account of the
CAF-hood of the mk_integer field in LitInteger; see TidyPgm.cafRefsL.
Indeed this is the only reason we put the mk_integer field in the
literal -- otherwise we could just look it up in CorePrep.
When we initally build an Integer literal, notably when
deserialising it from an interface file (see the Binary instance
below), we don't have convenient access to the mkInteger Id. So we
just use an error thunk, and fill in the real Id when we do tcIfaceLit
in TcIface.
Binary instance
......@@ -205,8 +198,8 @@ instance Binary Literal where
return (MachLabel aj mb fod)
_ -> do
i <- get bh
-- See Note [Integer literals]
return $ mkLitInteger i (panic "Evaluated the place holder for mkInteger")
-- See Note [Integer literals] in Literal
\end{code}
\begin{code}
......@@ -267,7 +260,7 @@ mkMachChar = MachChar
mkMachString :: String -> Literal
mkMachString s = MachStr (mkFastString s) -- stored UTF-8 encoded
mkLitInteger :: Integer -> Id -> Literal
mkLitInteger :: Integer -> Type -> Literal
mkLitInteger = LitInteger
inIntRange, inWordRange :: Integer -> Bool
......@@ -391,12 +384,7 @@ literalType (MachWord64 _) = word64PrimTy
literalType (MachFloat _) = floatPrimTy
literalType (MachDouble _) = doublePrimTy
literalType (MachLabel _ _ _) = addrPrimTy
literalType (LitInteger _ mk_integer_id)
-- We really mean idType, rather than varType, but importing Id
-- causes a module import loop
= case varType mk_integer_id of
FunTy _ (FunTy _ integerTy) -> integerTy
_ -> panic "literalType: mkIntegerId has the wrong type"
literalType (LitInteger _ t) = t
absentLiteralOf :: TyCon -> Maybe Literal
-- Return a literal of the appropriate primtive
......
......@@ -8,11 +8,12 @@ Core pass to saturate constructors and PrimOps
{-# LANGUAGE BangPatterns #-}
module CorePrep (
corePrepPgm, corePrepExpr
corePrepPgm, corePrepExpr, cvtLitInteger
) where
#include "HsVersions.h"
import HscTypes
import PrelNames
import CoreUtils
import CoreArity
......@@ -24,6 +25,8 @@ import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here
import Type
import Literal
import Coercion
import TcEnv
import TcRnMonad
import TyCon
import Demand
import Var
......@@ -43,7 +46,6 @@ import DynFlags
import Util
import Pair
import Outputable
import MonadUtils
import FastString
import Config
import Data.Bits
......@@ -100,8 +102,8 @@ The goal of this pass is to prepare for code generation.
9. Replace (lazy e) by e. See Note [lazyId magic] in MkId.lhs
10. Convert (LitInteger i mkInteger) into the core representation
for the Integer i. Normally this uses the mkInteger Id, but if
10. Convert (LitInteger i t) into the core representation
for the Integer i. Normally this uses mkInteger, but if
we are using the integer-gmp implementation then there is a
special case where we use the S# constructor for Integers that
are in the range of Int.
......@@ -150,35 +152,37 @@ type CpeRhs = CoreExpr -- Non-terminal 'rhs'
%************************************************************************
\begin{code}
corePrepPgm :: DynFlags -> CoreProgram -> [TyCon] -> IO CoreProgram
corePrepPgm dflags binds data_tycons = do
corePrepPgm :: DynFlags -> HscEnv -> CoreProgram -> [TyCon] -> IO CoreProgram
corePrepPgm dflags hsc_env binds data_tycons = do
showPass dflags "CorePrep"
us <- mkSplitUniqSupply 's'
initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env
let implicit_binds = mkDataConWorkers data_tycons
-- NB: we must feed mkImplicitBinds through corePrep too
-- so that they are suitably cloned and eta-expanded
binds_out = initUs_ us $ do
floats1 <- corePrepTopBinds binds
floats2 <- corePrepTopBinds implicit_binds
floats1 <- corePrepTopBinds initialCorePrepEnv binds
floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds
return (deFloatTop (floats1 `appendFloats` floats2))
endPass dflags CorePrep binds_out []
return binds_out
corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
corePrepExpr dflags expr = do
corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
corePrepExpr dflags hsc_env expr = do
showPass dflags "CorePrep"
us <- mkSplitUniqSupply 's'
let new_expr = initUs_ us (cpeBodyNF emptyCorePrepEnv expr)
initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env
let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)
dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)
return new_expr
corePrepTopBinds :: [CoreBind] -> UniqSM Floats
corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats
-- Note [Floating out of top level bindings]
corePrepTopBinds binds
= go emptyCorePrepEnv binds
corePrepTopBinds initialCorePrepEnv binds
= go initialCorePrepEnv binds
where
go _ [] = return emptyFloats
go env (bind : binds) = do (env', bind') <- cpeBind TopLevel env bind
......@@ -463,8 +467,8 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr)
cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr)
cpeRhsE env (Lit (LitInteger i mk_integer))
= cpeRhsE env (cvtLitInteger i mk_integer)
cpeRhsE env (Lit (LitInteger i _))
= cpeRhsE env (cvtLitInteger (getMkIntegerId env) i)
cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
cpeRhsE env expr@(Var {}) = cpeApp env expr
......@@ -514,13 +518,13 @@ cpeRhsE env (Case scrut bndr ty alts)
; rhs' <- cpeBodyNF env2 rhs
; return (con, bs', rhs') }
cvtLitInteger :: Integer -> Id -> CoreExpr
cvtLitInteger :: Id -> Integer -> CoreExpr
-- Here we convert a literal Integer to the low-level
-- represenation. Exactly how we do this depends on the
-- library that implements Integer. If it's GMP we
-- use the S# data constructor for small literals.
-- See Note [Integer literals] in Literal
cvtLitInteger i mk_integer
cvtLitInteger mk_integer i
| cIntegerLibraryType == IntegerGMP
, inIntRange i -- Special case for small integers in GMP
= mkConApp integerGmpSDataCon [Lit (mkMachInt i)]
......@@ -1144,23 +1148,32 @@ allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
-- The environment
-- ---------------------------------------------------------------------------
data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids
data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids
Id -- mkIntegerId
emptyCorePrepEnv :: CorePrepEnv
emptyCorePrepEnv = CPE emptyVarEnv
mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv
mkInitialCorePrepEnv hsc_env
= do mkIntegerId <- liftM tyThingId
$ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName)
return $ CPE emptyVarEnv mkIntegerId
extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id')
extendCorePrepEnv (CPE env mkIntegerId) id id'
= CPE (extendVarEnv env id id') mkIntegerId
extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
extendCorePrepEnvList (CPE env) prs = CPE (extendVarEnvList env prs)
extendCorePrepEnvList (CPE env mkIntegerId) prs
= CPE (extendVarEnvList env prs) mkIntegerId
lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
lookupCorePrepEnv (CPE env) id
lookupCorePrepEnv (CPE env _) id
= case lookupVarEnv env id of
Nothing -> id
Just id' -> id'
getMkIntegerId :: CorePrepEnv -> Id
getMkIntegerId (CPE _ mkIntegerId) = mkIntegerId
------------------------------------------------------------------------------
-- Cloning binders
-- ---------------------------------------------------------------------------
......
......@@ -257,8 +257,8 @@ mkWordExprWord w = mkConApp wordDataCon [mkWordLitWord w]
-- | Create a 'CoreExpr' which will evaluate to the given @Integer@
mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer
mkIntegerExpr i = do mkIntegerId <- lookupId mkIntegerName
return (Lit (mkLitInteger i mkIntegerId))
mkIntegerExpr i = do t <- lookupTyCon integerTyConName
return (Lit (mkLitInteger i (mkTyConTy t)))
-- | Create a 'CoreExpr' which will evaluate to the given @Float@
mkFloatExpr :: Float -> CoreExpr
......
......@@ -997,7 +997,7 @@ tcIfaceExpr (IfaceExt gbl)
tcIfaceExpr (IfaceLit lit)
= do lit' <- tcIfaceLit lit
return (Lit lit')
tcIfaceExpr (IfaceFCall cc ty) = do
ty' <- tcIfaceType ty
u <- newUnique
......@@ -1081,12 +1081,12 @@ tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push)
-------------------------
tcIfaceLit :: Literal -> IfL Literal
-- Integer literals deserialise to (LitInteeger i <error thunk>)
-- so tcIfaceLit just fills in the mkInteger Id
-- Integer literals deserialise to (LitInteger i <error thunk>)
-- so tcIfaceLit just fills in the type.
-- See Note [Integer literals] in Literal
tcIfaceLit (LitInteger i _)
= do mkIntegerId <- tcIfaceExtId mkIntegerName
return (mkLitInteger i mkIntegerId)
= do t <- tcIfaceTyCon (IfaceTc integerTyConName)
return (mkLitInteger i (mkTyConTy t))
tcIfaceLit lit = return lit
-------------------------
......
......@@ -1259,7 +1259,7 @@ hscGenHardCode cgguts mod_summary = do
-- PREPARE FOR CODE GENERATION
-- Do saturation and convert to A-normal form
prepd_binds <- {-# SCC "CorePrep" #-}
corePrepPgm dflags core_binds data_tycons ;
corePrepPgm dflags hsc_env core_binds data_tycons ;
----------------- Convert to STG ------------------
(stg_binds, cost_centre_info)
<- {-# SCC "CoreToStg" #-}
......@@ -1312,8 +1312,9 @@ hscInteractive (iface, details, cgguts) mod_summary = do
-------------------
-- PREPARE FOR CODE GENERATION
-- Do saturation and convert to A-normal form
hsc_env <- getHscEnv
prepd_binds <- {-# SCC "CorePrep" #-}
liftIO $ corePrepPgm dflags core_binds data_tycons ;
liftIO $ corePrepPgm dflags hsc_env core_binds data_tycons
----------------- Generate byte code ------------------
comp_bc <- liftIO $ byteCodeGen dflags this_mod prepd_binds
data_tycons mod_breaks
......@@ -1498,7 +1499,7 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
{- Prepare For Code Generation -}
-- Do saturation and convert to A-normal form
prepd_binds <- {-# SCC "CorePrep" #-}
liftIO $ corePrepPgm dflags core_binds data_tycons
liftIO $ corePrepPgm dflags hsc_env core_binds data_tycons
{- Generate byte code -}
cbc <- liftIO $ byteCodeGen dflags this_mod
......@@ -1675,7 +1676,7 @@ hscCompileCoreExpr hsc_env srcspan ds_expr
let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
{- Prepare for codegen -}
prepd_expr <- corePrepExpr dflags tidy_expr
prepd_expr <- corePrepExpr dflags hsc_env tidy_expr
{- Lint if necessary -}
-- ToDo: improve SrcLoc
......
......@@ -17,6 +17,7 @@ import CoreUnfold
import CoreFVs
import CoreTidy
import CoreMonad
import CorePrep
import CoreUtils
import Literal
import Rules
......@@ -34,7 +35,10 @@ import Name hiding (varName)
import NameSet
import NameEnv
import Avail
import PrelNames
import IfaceEnv
import TcEnv
import TcRnMonad
import TcType
import DataCon
import TyCon
......@@ -51,9 +55,9 @@ import SrcLoc
import Util
import FastString
import Control.Monad ( when )
import Control.Monad
import Data.List ( sortBy )
import Data.IORef ( IORef, readIORef, writeIORef )
import Data.IORef ( readIORef, writeIORef )
\end{code}
......@@ -325,8 +329,8 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
-- Then pick just the ones we need to expose
-- See Note [Which rules to expose]
; let { (tidy_env, tidy_binds)
= tidyTopBinds hsc_env unfold_env tidy_occ_env binds }
; (tidy_env, tidy_binds)
<- tidyTopBinds hsc_env unfold_env tidy_occ_env binds
; let { export_set = availsToNameSet exports
; final_ids = [ id | id <- bindersOfBinds tidy_binds,
......@@ -1036,38 +1040,41 @@ tidyTopBinds :: HscEnv
-> UnfoldEnv
-> TidyOccEnv
-> CoreProgram
-> (TidyEnv, CoreProgram)
-> IO (TidyEnv, CoreProgram)
tidyTopBinds hsc_env unfold_env init_occ_env binds
= tidy init_env binds
= do mkIntegerId <- liftM tyThingId
$ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName)
return $ tidy mkIntegerId init_env binds
where
init_env = (init_occ_env, emptyVarEnv)
this_pkg = thisPackage (hsc_dflags hsc_env)
tidy env [] = (env, [])
tidy env (b:bs) = let (env1, b') = tidyTopBind this_pkg unfold_env env b
(env2, bs') = tidy env1 bs
in
(env2, b':bs')
tidy _ env [] = (env, [])
tidy mkIntegerId env (b:bs) = let (env1, b') = tidyTopBind this_pkg mkIntegerId unfold_env env b
(env2, bs') = tidy mkIntegerId env1 bs
in
(env2, b':bs')
------------------------
tidyTopBind :: PackageId
-> Id
-> UnfoldEnv
-> TidyEnv
-> CoreBind
-> (TidyEnv, CoreBind)
tidyTopBind this_pkg unfold_env (occ_env,subst1) (NonRec bndr rhs)
tidyTopBind this_pkg mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr rhs)
= (tidy_env2, NonRec bndr' rhs')
where
Just (name',show_unfold) = lookupVarEnv unfold_env bndr
caf_info = hasCafRefs this_pkg subst1 (idArity bndr) rhs
caf_info = hasCafRefs this_pkg (mkIntegerId, subst1) (idArity bndr) rhs
(bndr', rhs') = tidyTopPair show_unfold tidy_env2 caf_info name' (bndr, rhs)
subst2 = extendVarEnv subst1 bndr bndr'
tidy_env2 = (occ_env, subst2)
tidyTopBind this_pkg unfold_env (occ_env,subst1) (Rec prs)
tidyTopBind this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs)
= (tidy_env2, Rec prs')
where
prs' = [ tidyTopPair show_unfold tidy_env2 caf_info name' (id,rhs)
......@@ -1084,7 +1091,7 @@ tidyTopBind this_pkg unfold_env (occ_env,subst1) (Rec prs)
-- the CafInfo for a recursive group says whether *any* rhs in
-- the group may refer indirectly to a CAF (because then, they all do).
caf_info
| or [ mayHaveCafRefs (hasCafRefs this_pkg subst1 (idArity bndr) rhs)
| or [ mayHaveCafRefs (hasCafRefs this_pkg (mkIntegerId, subst1) (idArity bndr) rhs)
| (bndr,rhs) <- prs ] = MayHaveCafRefs
| otherwise = NoCafRefs
......@@ -1221,7 +1228,7 @@ it as a CAF. In these cases however, we would need to use an additional
CAF list to keep track of non-collectable CAFs.
\begin{code}
hasCafRefs :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
hasCafRefs :: PackageId -> (Id, VarEnv Var) -> Arity -> CoreExpr -> CafInfo
hasCafRefs this_pkg p arity expr
| is_caf || mentions_cafs = MayHaveCafRefs
| otherwise = NoCafRefs
......@@ -1236,7 +1243,7 @@ hasCafRefs this_pkg p arity expr
-- CorePrep later on, and we don't want to duplicate that
-- knowledge in rhsIsStatic below.
cafRefsE :: VarEnv Id -> Expr a -> FastBool
cafRefsE :: (Id, VarEnv Id) -> Expr a -> FastBool
cafRefsE p (Var id) = cafRefsV p id
cafRefsE p (Lit lit) = cafRefsL p lit
cafRefsE p (App f a) = fastOr (cafRefsE p f) (cafRefsE p) a
......@@ -1248,18 +1255,19 @@ cafRefsE p (Cast e _co) = cafRefsE p e
cafRefsE _ (Type _) = fastBool False
cafRefsE _ (Coercion _) = fastBool False
cafRefsEs :: VarEnv Id -> [Expr a] -> FastBool
cafRefsEs :: (Id, VarEnv Id) -> [Expr a] -> FastBool
cafRefsEs _ [] = fastBool False
cafRefsEs p (e:es) = fastOr (cafRefsE p e) (cafRefsEs p) es
cafRefsL :: VarEnv Id -> Literal -> FastBool
-- Don't forget that the embeded mk_integer id might have Caf refs!
-- See Note [Integer literals] in Literal
cafRefsL p (LitInteger _ mk_integer) = cafRefsV p mk_integer
cafRefsL :: (Id, VarEnv Id) -> Literal -> FastBool
-- Don't forget that mk_integer id might have Caf refs!
-- We first need to convert the Integer into its final form, to
-- see whether mkInteger is used.
cafRefsL p@(mk_integer, _) (LitInteger i _) = cafRefsE p (cvtLitInteger mk_integer i)
cafRefsL _ _ = fastBool False
cafRefsV :: VarEnv Id -> Id -> FastBool
cafRefsV p id
cafRefsV :: (Id, VarEnv Id) -> Id -> FastBool
cafRefsV (_, p) id
| not (isLocalId id) = fastBool (mayHaveCafRefs (idCafInfo id))
| Just id' <- lookupVarEnv p id = fastBool (mayHaveCafRefs (idCafInfo id'))
| otherwise = fastBool False
......
......@@ -31,7 +31,6 @@ import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
import CoreUtils ( cheapEqExpr, exprIsHNF )
import CoreUnfold ( exprIsConApp_maybe )
import Type
import TypeRep
import OccName ( occNameFS )
import PrelNames
import Maybes ( orElse )
......@@ -789,18 +788,15 @@ match_Integer_divop_both :: (Integer -> Integer -> (Integer, Integer))
-> [Expr CoreBndr]
-> Maybe (Expr CoreBndr)
match_Integer_divop_both divop _ id_unf [xl,yl]
| Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
| Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl
, Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
, y /= 0
, (r,s) <- x `divop` y
= case idType i of
FunTy _ (FunTy _ integerTy) ->
Just $ mkConApp (tupleCon UnboxedTuple 2)
[Type integerTy,
Type integerTy,
Lit (LitInteger r i),
Lit (LitInteger s i)]
_ -> panic "match_Integer_divop_both: mkIntegerId has the wrong type"
= Just $ mkConApp (tupleCon UnboxedTuple 2)
[Type t,
Type t,
Lit (LitInteger r t),
Lit (LitInteger s t)]
match_Integer_divop_both _ _ _ _ = Nothing
-- This helper is used for the quotRem and divMod functions
......
......@@ -71,7 +71,6 @@ import CoreSyn
import PprCore
import CoreUtils
import CoreLint ( lintCoreBindings )
import PrelNames ( iNTERACTIVE )
import HscTypes
import Module ( Module )
import DynFlags
......@@ -84,7 +83,7 @@ import Id ( Id )
import IOEnv hiding ( liftIO, failM, failWithM )
import qualified IOEnv ( liftIO )
import TcEnv ( tcLookupGlobal )
import TcRnMonad ( TcM, initTc )
import TcRnMonad ( initTcForLookup )
import Outputable
import FastString
......@@ -1022,13 +1021,6 @@ dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
\end{code}
\begin{code}
initTcForLookup :: HscEnv -> TcM a -> IO a
initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
\end{code}
%************************************************************************
%* *
......
......@@ -44,6 +44,7 @@ import UniqSupply
import Unique
import UniqFM
import DynFlags
import Maybes
import StaticFlags
import FastString
import Panic
......@@ -185,6 +186,9 @@ initTcPrintErrors -- Used from the interactive loop only
-> IO (Messages, Maybe r)
initTcPrintErrors env mod todo = initTc env HsSrcFile False mod todo
initTcForLookup :: HscEnv -> TcM a -> IO a
initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
\end{code}
%************************************************************************
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment