diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs --- a/compiler/basicTypes/Literal.hs +++ b/compiler/basicTypes/Literal.hs @@ -110,7 +110,9 @@ | LitNumber !LitNumType !Integer Type -- ^ Any numeric literal that can be - -- internally represented with an Integer + -- internally represented with an Integer. + -- See Note [Types of LitNumbers] below for the + -- Type field. | LitString ByteString -- ^ A string-literal: stored and emitted -- UTF-8 encoded, we'll arrange to decode it @@ -251,6 +253,7 @@ 6 -> do nt <- get bh i <- get bh + -- Note [Types of LitNumbers] let t = case nt of LitNumInt -> intPrimTy LitNumInt64 -> int64PrimTy @@ -267,20 +270,15 @@ return (LitRubbish) instance Outputable Literal where - ppr lit = pprLiteral (\d -> d) lit + ppr = pprLiteral id instance Eq Literal where - a == b = case (a `compare` b) of { EQ -> True; _ -> False } - a /= b = case (a `compare` b) of { EQ -> False; _ -> True } + a == b = compare a b == EQ -- | Needed for the @Ord@ instance of 'AltCon', which in turn is needed in -- 'TrieMap.CoreMap'. instance Ord Literal where - a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } - a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } - a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - compare a b = cmpLit a b + compare = cmpLit {- Construction @@ -309,13 +307,11 @@ wrapLitNumber :: DynFlags -> Literal -> Literal wrapLitNumber dflags v@(LitNumber nt i t) = case nt of LitNumInt -> case platformWordSize (targetPlatform dflags) of - 4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) t - 8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t - w -> panic ("wrapLitNumber: Unknown platformWordSize: " ++ show w) + PW4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) t + PW8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t LitNumWord -> case platformWordSize (targetPlatform dflags) of - 4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) t - 8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t - w -> panic ("wrapLitNumber: Unknown platformWordSize: " ++ show w) + PW4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) t + PW8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t LitNumInt64 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t LitNumWord64 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t LitNumInteger -> v @@ -644,6 +640,26 @@ {- Types ~~~~~ + +Note [Types of LitNumbers] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A LitNumber's type is always known from its LitNumType: + + LitNumInteger -> Integer + LitNumNatural -> Natural + LitNumInt -> Int# (intPrimTy) + LitNumInt64 -> Int64# (int64PrimTy) + LitNumWord -> Word# (wordPrimTy) + LitNumWord64 -> Word64# (word64PrimTy) + +The reason why we have a Type field is because Integer and Natural types live +outside of GHC (in the libraries), so we have to get the actual Type via +lookupTyCon, tcIfaceTyConByName etc. that's too inconvenient in the call sites +of literalType, so we do that when creating these literals, and literalType +simply reads the field. + +(But see also Note [Integer literals] and Note [Natural literals]) -} -- | Find the Haskell 'Type' the literal occupies @@ -654,7 +670,7 @@ literalType (LitFloat _) = floatPrimTy literalType (LitDouble _) = doublePrimTy literalType (LitLabel _ _ _) = addrPrimTy -literalType (LitNumber _ _ t) = t +literalType (LitNumber _ _ t) = t -- Note [Types of LitNumbers] literalType (LitRubbish) = mkForAllTy a Inferred (mkTyVarTy a) where a = alphaTyVarUnliftedRep diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs --- a/compiler/coreSyn/CoreOpt.hs +++ b/compiler/coreSyn/CoreOpt.hs @@ -28,11 +28,13 @@ import CoreSubst import CoreUtils import CoreFVs +import {-#SOURCE #-} CoreUnfold ( mkUnfolding ) import MkCore ( FloatBind(..) ) import PprCore ( pprCoreBindings, pprRules ) import OccurAnal( occurAnalyseExpr, occurAnalysePgm ) import Literal ( Literal(LitString) ) import Id +import IdInfo ( unfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) ) import Var ( isNonCoVarId ) import VarSet import VarEnv @@ -153,7 +155,7 @@ -- hence paying just a substitution do_one (env, binds') bind - = case simple_opt_bind env bind of + = case simple_opt_bind env bind TopLevel of (env', Nothing) -> (env', binds') (env', Just bind') -> (env', bind':binds') @@ -200,7 +202,7 @@ simple_opt_clo env (e_env, e) = simple_opt_expr (soeSetInScope env e_env) e -simple_opt_expr :: SimpleOptEnv -> InExpr -> OutExpr +simple_opt_expr :: HasCallStack => SimpleOptEnv -> InExpr -> OutExpr simple_opt_expr env expr = go expr where @@ -224,9 +226,9 @@ where co' = optCoercion (soe_dflags env) (getTCvSubst subst) co - go (Let bind body) = case simple_opt_bind env bind of - (env', Nothing) -> simple_opt_expr env' body - (env', Just bind) -> Let bind (simple_opt_expr env' body) + go (Let bind body) = case simple_opt_bind env bind NotTopLevel of + (env', Nothing) -> simple_opt_expr env' body + (env', Just bind) -> Let bind (simple_opt_expr env' body) go lam@(Lam {}) = go_lam env [] lam go (Case e b ty as) @@ -239,7 +241,7 @@ DEFAULT -> go rhs _ -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs where - (env', mb_prs) = mapAccumL simple_out_bind env $ + (env', mb_prs) = mapAccumL (simple_out_bind NotTopLevel) env $ zipEqual "simpleOptExpr" bs es -- Note [Getting the map/coerce RULE to work] @@ -301,7 +303,7 @@ simple_app env (Lam b e) (a:as) = wrapLet mb_pr (simple_app env' e as) where - (env', mb_pr) = simple_bind_pair env b Nothing a + (env', mb_pr) = simple_bind_pair env b Nothing a NotTopLevel simple_app env (Tick t e) as -- Okay to do "(Tick t e) x ==> Tick t (e x)"? @@ -316,7 +318,7 @@ -- However, do /not/ do this transformation for join points -- See Note [simple_app and join points] simple_app env (Let bind body) args - = case simple_opt_bind env bind of + = case simple_opt_bind env bind NotTopLevel of (env', Nothing) -> simple_app env' body args (env', Just bind') | isJoinBind bind' -> finish_app env expr' args @@ -334,17 +336,17 @@ = finish_app env (App fun (simple_opt_clo env arg)) args ---------------------- -simple_opt_bind :: SimpleOptEnv -> InBind +simple_opt_bind :: SimpleOptEnv -> InBind -> TopLevelFlag -> (SimpleOptEnv, Maybe OutBind) -simple_opt_bind env (NonRec b r) +simple_opt_bind env (NonRec b r) top_level = (env', case mb_pr of Nothing -> Nothing Just (b,r) -> Just (NonRec b r)) where (b', r') = joinPointBinding_maybe b r `orElse` (b, r) - (env', mb_pr) = simple_bind_pair env b' Nothing (env,r') + (env', mb_pr) = simple_bind_pair env b' Nothing (env,r') top_level -simple_opt_bind env (Rec prs) +simple_opt_bind env (Rec prs) top_level = (env'', res_bind) where res_bind = Just (Rec (reverse rev_prs')) @@ -356,18 +358,20 @@ Just pr -> pr : prs Nothing -> prs) where - (env', mb_pr) = simple_bind_pair env b (Just b') (env,r) + (env', mb_pr) = simple_bind_pair env b (Just b') (env,r) top_level ---------------------- simple_bind_pair :: SimpleOptEnv -> InVar -> Maybe OutVar -> SimpleClo + -> TopLevelFlag -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) -- (simple_bind_pair subst in_var out_rhs) -- either extends subst with (in_var -> out_rhs) -- or returns Nothing simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst }) in_bndr mb_out_bndr clo@(rhs_env, in_rhs) + top_level | Type ty <- in_rhs -- let a::* = TYPE ty in , let out_ty = substTy (soe_subst rhs_env) ty = ASSERT( isTyVar in_bndr ) @@ -386,7 +390,7 @@ | otherwise = simple_out_bind_pair env in_bndr mb_out_bndr out_rhs - occ active stable_unf + occ active stable_unf top_level where stable_unf = isStableUnfolding (idUnfolding in_bndr) active = isAlwaysActive (idInlineActivation in_bndr) @@ -421,9 +425,11 @@ safe_to_inline (ManyOccs {}) = False ------------------- -simple_out_bind :: SimpleOptEnv -> (InVar, OutExpr) +simple_out_bind :: TopLevelFlag + -> SimpleOptEnv + -> (InVar, OutExpr) -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) -simple_out_bind env@(SOE { soe_subst = subst }) (in_bndr, out_rhs) +simple_out_bind top_level env@(SOE { soe_subst = subst }) (in_bndr, out_rhs) | Type out_ty <- out_rhs = ASSERT( isTyVar in_bndr ) (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) @@ -434,15 +440,15 @@ | otherwise = simple_out_bind_pair env in_bndr Nothing out_rhs - (idOccInfo in_bndr) True False + (idOccInfo in_bndr) True False top_level ------------------- simple_out_bind_pair :: SimpleOptEnv -> InId -> Maybe OutId -> OutExpr - -> OccInfo -> Bool -> Bool + -> OccInfo -> Bool -> Bool -> TopLevelFlag -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) simple_out_bind_pair env in_bndr mb_out_bndr out_rhs - occ_info active stable_unf + occ_info active stable_unf top_level | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr ) -- Type and coercion bindings are caught earlier -- See Note [CoreSyn type and coercion invariant] @@ -456,7 +462,7 @@ (env', bndr1) = case mb_out_bndr of Just out_bndr -> (env, out_bndr) Nothing -> subst_opt_bndr env in_bndr - out_bndr = add_info env' in_bndr bndr1 + out_bndr = add_info env' in_bndr top_level out_rhs bndr1 post_inline_unconditionally :: Bool post_inline_unconditionally @@ -528,6 +534,25 @@ The simple thing to do is to disable this transformation for join points in the simple optimiser + +Note [The Let-Unfoldings Invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A program has the Let-Unfoldings property iff: + +- For every let-bound variable f, whether top-level or nested, whether + recursive or not: + - Both the binding Id of f, and every occurence Id of f, has an idUnfolding. + - For non-INLINE things, that unfolding will be f's right hand sids + - For INLINE things (which have a "stable" unfolding) that unfolding is + semantically equivalent to f's RHS, but derived from the original RHS of f + rather that its current RHS. + +Informally, we can say that in a program that has the Let-Unfoldings property, +all let-bound Id's have an explicit unfolding attached to them. + +Currently, the simplifier guarantees the Let-Unfoldings invariant for anything +it outputs. + -} ---------------------- @@ -545,8 +570,9 @@ (subst_cv, cv') = substCoVarBndr subst bndr subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId) --- Nuke all fragile IdInfo, unfolding, and RULES; --- it gets added back later by add_info +-- Nuke all fragile IdInfo, unfolding, and RULES; it gets added back later by +-- add_info. +-- -- Rather like SimplEnv.substIdBndr -- -- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr @@ -577,14 +603,36 @@ new_inl = delVarEnv inl old_id ---------------------- -add_info :: SimpleOptEnv -> InVar -> OutVar -> OutVar -add_info env old_bndr new_bndr +add_info :: SimpleOptEnv -> InVar -> TopLevelFlag -> OutExpr -> OutVar -> OutVar +add_info env old_bndr top_level new_rhs new_bndr | isTyVar old_bndr = new_bndr - | otherwise = maybeModifyIdInfo mb_new_info new_bndr + | otherwise = lazySetIdInfo new_bndr new_info where - subst = soe_subst env - mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr) + subst = soe_subst env + dflags = soe_dflags env + old_info = idInfo old_bndr + -- Add back in the rules and unfolding which were + -- removed by zapFragileIdInfo in subst_opt_id_bndr. + -- + -- See Note [The Let-Unfoldings Invariant] + new_info = idInfo new_bndr `setRuleInfo` new_rules + `setUnfoldingInfo` new_unfolding + + old_rules = ruleInfo old_info + new_rules = substSpec subst new_bndr old_rules + + old_unfolding = unfoldingInfo old_info + new_unfolding | isStableUnfolding old_unfolding + = substUnfolding subst old_unfolding + | otherwise + = unfolding_from_rhs + + unfolding_from_rhs = mkUnfolding dflags InlineRhs + (isTopLevel top_level) + False -- may be bottom or not + new_rhs + simpleUnfoldingFun :: IdUnfoldingFun simpleUnfoldingFun id | isAlwaysActive (idInlineActivation id) = idUnfolding id @@ -1413,10 +1461,13 @@ | otherwise = (reverse bs, mkCast (Lam b e) co) -{- Note [collectBindersPushingCo] +{- + +Note [collectBindersPushingCo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We just look for coercions of form -> blah (and similarly for foralls) to keep this function simple. We could do more elaborate stuff, but it'd involve substitution etc. + -} diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs --- a/compiler/coreSyn/CoreSubst.hs +++ b/compiler/coreSyn/CoreSubst.hs @@ -61,7 +61,6 @@ import Maybes import Util import Outputable -import PprCore () -- Instances import Data.List diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs --- a/compiler/coreSyn/CoreSyn.hs +++ b/compiler/coreSyn/CoreSyn.hs @@ -655,6 +655,16 @@ Invariant 4 is subtle; see Note [The polymorphism rule of join points]. +Invariant 6 is to enable code like this: + + f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T). + join j :: a + j = error @r @a "bloop" + in case x of + A -> j + B -> j + C -> error @r @a "blurp" + Core Lint will check these invariants, anticipating that any binder whose OccInfo is marked AlwaysTailCalled will become a join point as soon as the simplifier (or simpleOptPgm) runs. diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs --- a/compiler/coreSyn/CoreUnfold.hs +++ b/compiler/coreSyn/CoreUnfold.hs @@ -46,7 +46,6 @@ import DynFlags import CoreSyn -import PprCore () -- Instances import OccurAnal ( occurAnalyseExpr_NoBinderSwap ) import CoreOpt import CoreArity ( manifestArity ) @@ -483,7 +482,7 @@ n_val_bndrs = length val_bndrs mk_discount :: Bag (Id,Int) -> Id -> Int - mk_discount cbs bndr = foldlBag combine 0 cbs + mk_discount cbs bndr = foldl' combine 0 cbs where combine acc (bndr', disc) | bndr == bndr' = acc `plus_disc` disc diff --git a/compiler/coreSyn/CoreUnfold.hs-boot b/compiler/coreSyn/CoreUnfold.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/coreSyn/CoreUnfold.hs-boot @@ -0,0 +1,14 @@ +module CoreUnfold ( + mkUnfolding + ) where + +import GhcPrelude +import CoreSyn +import DynFlags + +mkUnfolding :: DynFlags + -> UnfoldingSource + -> Bool + -> Bool + -> CoreExpr + -> Unfolding diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -28,7 +28,6 @@ import HsExtension import HsTypes -import PprCore () import CoreSyn import TcEvidence import Type diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs --- a/compiler/hsSyn/HsSyn.hs +++ b/compiler/hsSyn/HsSyn.hs @@ -50,7 +50,7 @@ import BasicTypes ( Fixity, WarningTxt ) import HsUtils import HsDoc -import HsInstances () +import HsInstances () -- For Data instances -- others: import Outputable diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -77,7 +77,6 @@ import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) import HsExtension -import HsLit () -- for instances import Id ( Id ) import Name( Name ) diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -56,7 +56,7 @@ mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup, -- Types - mkHsAppTy, mkHsAppKindTy, userHsTyVarBndrs, userHsLTyVarBndrs, + mkHsAppTy, mkHsAppKindTy, mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, mkHsSigEnv, nlHsAppTy, nlHsAppKindTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp, @@ -368,18 +368,7 @@ mkHsStringPrimLit :: FastString -> HsLit (GhcPass p) mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs) -------------- -userHsLTyVarBndrs :: SrcSpan -> [Located (IdP (GhcPass p))] - -> [LHsTyVarBndr (GhcPass p)] --- Caller sets location -userHsLTyVarBndrs loc bndrs = [ cL loc (UserTyVar noExtField v) | v <- bndrs ] -userHsTyVarBndrs :: SrcSpan -> [IdP (GhcPass p)] -> [LHsTyVarBndr (GhcPass p)] --- Caller sets location -userHsTyVarBndrs loc bndrs = [ cL loc (UserTyVar noExtField (cL loc v)) - | v <- bndrs ] - - {- ************************************************************************ * * @@ -1000,7 +989,7 @@ collect_binds :: Bool -> LHsBindsLR (GhcPass p) idR -> [IdP (GhcPass p)] -> [IdP (GhcPass p)] -- Collect Ids, or Ids + pattern synonyms, depending on boolean flag -collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds +collect_binds ps binds acc = foldr (collect_bind ps . unLoc) acc binds collect_bind :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => Bool -> HsBindLR p idR -> [IdP p] -> [IdP p] @@ -1019,7 +1008,7 @@ collectMethodBinders :: LHsBindsLR idL idR -> [Located (IdP idL)] -- Used exclusively for the bindings of an instance decl which are all FunBinds -collectMethodBinders binds = foldrBag (get . unLoc) [] binds +collectMethodBinders binds = foldr (get . unLoc) [] binds where get (FunBind { fun_id = f }) fs = f : fs get _ fs = fs @@ -1201,7 +1190,7 @@ -- names are collected by collectHsValBinders. hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors" hsPatSynSelectors (XValBindsLR (NValBinds binds _)) - = foldrBag addPatSynSelector [] . unionManyBags $ map snd binds + = foldr addPatSynSelector [] . unionManyBags $ map snd binds addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p] addPatSynSelector bind sels diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -46,7 +46,7 @@ import IfaceType import BinFingerprint import CoreSyn( IsOrphan, isOrphan ) -import PprCore() -- Printing DFunArgs +import DynFlags( gopt, GeneralFlag (Opt_PrintAxiomIncomps) ) import Demand import Class import FieldLabel @@ -66,7 +66,7 @@ import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) import Var( VarBndr(..), binderVar ) import TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag ) -import Util( dropList, filterByList ) +import Util( dropList, filterByList, notNull, unzipWith ) import DataCon (SrcStrictness(..), SrcUnpackedness(..)) import Lexeme (isLexSym) @@ -545,7 +545,29 @@ In general we retain all info that is left by CoreTidy.tidyLetBndr, since that is what is seen by importing module with --make +Note [Displaying axiom incompatibilities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With -fprint-axiom-incomps we display which closed type family equations +are incompatible with which. This information is sometimes necessary +because GHC doesn't try equations in order: any equation can be used when +all preceding equations that are incompatible with it do not apply. +For example, the last "a && a = a" equation in Data.Type.Bool.&& is +actually compatible with all previous equations, and can reduce at any +time. + +This is displayed as: +Prelude> :i Data.Type.Equality.== +type family (==) (a :: k) (b :: k) :: Bool + where + {- #0 -} (==) (f a) (g b) = (f == g) && (a == b) + {- #1 -} (==) a a = 'True + -- incompatible with: #0 + {- #2 -} (==) _1 _2 = 'False + -- incompatible with: #1, #0 +The comment after an equation refers to all previous equations (0-indexed) +that are incompatible with it. + ************************************************************************ * * Printing IfaceDecl @@ -553,7 +575,7 @@ ************************************************************************ -} -pprAxBranch :: SDoc -> IfaceAxBranch -> SDoc +pprAxBranch :: SDoc -> BranchIndex -> IfaceAxBranch -> SDoc -- The TyCon might be local (just an OccName), or this might -- be a branch for an imported TyCon, so it would be an ExtName -- So it's easier to take an SDoc here @@ -563,22 +585,32 @@ -- in debug messages -- in :info F for GHCi, which goes via toConToIfaceDecl on the family tycon -- For user error messages we use Coercion.pprCoAxiom and friends -pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs - , ifaxbCoVars = _cvs - , ifaxbLHS = pat_tys - , ifaxbRHS = rhs - , ifaxbIncomps = incomps }) +pprAxBranch pp_tc idx (IfaceAxBranch { ifaxbTyVars = tvs + , ifaxbCoVars = _cvs + , ifaxbLHS = pat_tys + , ifaxbRHS = rhs + , ifaxbIncomps = incomps }) = WARN( not (null _cvs), pp_tc $$ ppr _cvs ) hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs)) $+$ - nest 2 maybe_incomps + nest 4 maybe_incomps where -- See Note [Printing foralls in type family instances] in IfaceType - ppr_binders = pprUserIfaceForAll $ map (mkIfaceForAllTvBndr Specified) tvs + ppr_binders = maybe_index <+> + pprUserIfaceForAll (map (mkIfaceForAllTvBndr Specified) tvs) pp_lhs = hang pp_tc 2 (pprParendIfaceAppArgs pat_tys) - maybe_incomps = ppUnless (null incomps) $ parens $ - text "incompatible indices:" <+> ppr incomps + -- See Note [Displaying axiom incompatibilities] + maybe_index + = sdocWithDynFlags $ \dflags -> + ppWhen (gopt Opt_PrintAxiomIncomps dflags) $ + text "{-" <+> (text "#" <> ppr idx) <+> text "-}" + maybe_incomps + = sdocWithDynFlags $ \dflags -> + ppWhen (gopt Opt_PrintAxiomIncomps dflags && notNull incomps) $ + text "--" <+> text "incompatible with:" + <+> pprWithCommas (\incomp -> text "#" <> ppr incomp) incomps + instance Outputable IfaceAnnotation where ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value @@ -860,11 +892,11 @@ = ppShowIface ss (text "built-in") pp_branches (IfaceClosedSynFamilyTyCon (Just (ax, brs))) - = vcat (map (pprAxBranch + = vcat (unzipWith (pprAxBranch (pprPrefixIfDeclBndr (ss_how_much ss) (occName tycon)) - ) brs) + ) $ zip [0..] brs) $$ ppShowIface ss (text "axiom" <+> ppr ax) pp_branches _ = Outputable.empty @@ -900,7 +932,7 @@ pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon , ifAxBranches = branches }) = hang (text "axiom" <+> ppr name <+> dcolon) - 2 (vcat $ map (pprAxBranch (ppr tycon)) branches) + 2 (vcat $ unzipWith (pprAxBranch (ppr tycon)) $ zip [0..] branches) pprCType :: Maybe CType -> SDoc pprCType Nothing = Outputable.empty diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -60,7 +60,6 @@ fFlags, fLangFlags, xFlags, wWarningFlags, dynFlagDependencies, - tablesNextToCode, makeDynFlagsConsistent, shouldUseColor, shouldUseHexWordLiterals, @@ -160,6 +159,7 @@ opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_i, opt_P_signature, opt_windres, opt_lo, opt_lc, opt_lcc, + tablesNextToCode, -- ** Manipulating DynFlags addPluginModuleName, @@ -451,7 +451,6 @@ | Opt_D_dump_parsed_ast | Opt_D_dump_rn | Opt_D_dump_rn_ast - | Opt_D_dump_shape | Opt_D_dump_simpl | Opt_D_dump_simpl_iterations | Opt_D_dump_spec @@ -522,6 +521,7 @@ | Opt_PrintExplicitCoercions | Opt_PrintExplicitRuntimeReps | Opt_PrintEqualityRelations + | Opt_PrintAxiomIncomps | Opt_PrintUnicodeSyntax | Opt_PrintExpandedSynonyms | Opt_PrintPotentialInstances @@ -1493,6 +1493,9 @@ opt_i :: DynFlags -> [String] opt_i dflags= toolSettings_opt_i $ toolSettings dflags +tablesNextToCode :: DynFlags -> Bool +tablesNextToCode = platformMisc_tablesNextToCode . platformMisc + -- | The directory for this version of ghc in the user's app directory -- (typically something like @~/.ghc/x86_64-linux-7.6.3@) -- @@ -1664,15 +1667,6 @@ (targetPlatform dflags) (platformMisc dflags) --- Determines whether we will be compiling --- info tables that reside just before the entry code, or with an --- indirection to the entry code. See TABLES_NEXT_TO_CODE in --- includes/rts/storage/InfoTables.h. -tablesNextToCode :: DynFlags -> Bool -tablesNextToCode dflags = - not (platformUnregisterised $ targetPlatform dflags) && - platformMisc_tablesNextToCode (platformMisc dflags) - data DynLibLoader = Deployable | SystemDependent @@ -2358,7 +2352,6 @@ enableIfVerbose Opt_D_dump_vt_trace = False enableIfVerbose Opt_D_dump_tc = False enableIfVerbose Opt_D_dump_rn = False - enableIfVerbose Opt_D_dump_shape = False enableIfVerbose Opt_D_dump_rn_stats = False enableIfVerbose Opt_D_dump_hi_diffs = False enableIfVerbose Opt_D_verbose_core2core = False @@ -3412,8 +3405,6 @@ (setDumpFlag Opt_D_dump_worker_wrapper) , make_ord_flag defGhcFlag "ddump-rn-trace" (setDumpFlag Opt_D_dump_rn_trace) - , make_ord_flag defGhcFlag "ddump-shape" - (setDumpFlag Opt_D_dump_shape) , make_ord_flag defGhcFlag "ddump-if-trace" (setDumpFlag Opt_D_dump_if_trace) , make_ord_flag defGhcFlag "ddump-cs-trace" @@ -4236,6 +4227,7 @@ flagSpec "print-explicit-coercions" Opt_PrintExplicitCoercions, flagSpec "print-explicit-runtime-reps" Opt_PrintExplicitRuntimeReps, flagSpec "print-equality-relations" Opt_PrintEqualityRelations, + flagSpec "print-axiom-incomps" Opt_PrintAxiomIncomps, flagSpec "print-unicode-syntax" Opt_PrintUnicodeSyntax, flagSpec "print-expanded-synonyms" Opt_PrintExpandedSynonyms, flagSpec "print-potential-instances" Opt_PrintPotentialInstances, @@ -5597,19 +5589,16 @@ tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD :: DynFlags -> Integer tARGET_MIN_INT dflags = case platformWordSize (targetPlatform dflags) of - 4 -> toInteger (minBound :: Int32) - 8 -> toInteger (minBound :: Int64) - w -> panic ("tARGET_MIN_INT: Unknown platformWordSize: " ++ show w) + PW4 -> toInteger (minBound :: Int32) + PW8 -> toInteger (minBound :: Int64) tARGET_MAX_INT dflags = case platformWordSize (targetPlatform dflags) of - 4 -> toInteger (maxBound :: Int32) - 8 -> toInteger (maxBound :: Int64) - w -> panic ("tARGET_MAX_INT: Unknown platformWordSize: " ++ show w) + PW4 -> toInteger (maxBound :: Int32) + PW8 -> toInteger (maxBound :: Int64) tARGET_MAX_WORD dflags = case platformWordSize (targetPlatform dflags) of - 4 -> toInteger (maxBound :: Word32) - 8 -> toInteger (maxBound :: Word64) - w -> panic ("tARGET_MAX_WORD: Unknown platformWordSize: " ++ show w) + PW4 -> toInteger (maxBound :: Word32) + PW8 -> toInteger (maxBound :: Word64) {- ----------------------------------------------------------------------------- diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -35,7 +35,6 @@ import ErrUtils import Util import Outputable -import Pretty () import Maybes import Bag ( emptyBag, listToBag, unitBag ) import MonadUtils diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs --- a/compiler/prelude/PrelRules.hs +++ b/compiler/prelude/PrelRules.hs @@ -433,10 +433,10 @@ -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do -- Do this by converting to Word and back. Obviously this won't work for big -- values, but its ok as we use it here -shiftRightLogical dflags x n - | wordSizeInBits dflags == 32 = fromIntegral (fromInteger x `shiftR` n :: Word32) - | wordSizeInBits dflags == 64 = fromIntegral (fromInteger x `shiftR` n :: Word64) - | otherwise = panic "shiftRightLogical: unsupported word size" +shiftRightLogical dflags x n = + case platformWordSize (targetPlatform dflags) of + PW4 -> fromIntegral (fromInteger x `shiftR` n :: Word32) + PW8 -> fromIntegral (fromInteger x `shiftR` n :: Word64) -------------------------- retLit :: (DynFlags -> Literal) -> RuleM CoreExpr @@ -489,7 +489,7 @@ _ -> mzero } wordSizeInBits :: DynFlags -> Integer -wordSizeInBits dflags = toInteger (platformWordSize (targetPlatform dflags) `shiftL` 3) +wordSizeInBits dflags = toInteger (platformWordSizeInBits (targetPlatform dflags)) -------------------------- floatOp2 :: (Rational -> Rational -> Rational) @@ -802,11 +802,12 @@ removeOp32 :: RuleM CoreExpr removeOp32 = do dflags <- getDynFlags - if wordSizeInBits dflags == 32 - then do - [e] <- getArgs - return e - else mzero + case platformWordSize (targetPlatform dflags) of + PW4 -> do + [e] <- getArgs + return e + PW8 -> + mzero getArgs :: RuleM [CoreExpr] getArgs = RuleM $ \_ _ args -> Just args diff --git a/compiler/simplStg/RepType.hs b/compiler/simplStg/RepType.hs --- a/compiler/simplStg/RepType.hs +++ b/compiler/simplStg/RepType.hs @@ -64,7 +64,7 @@ = False -- INVARIANT: the result list is never empty. -typePrimRepArgs :: Type -> [PrimRep] +typePrimRepArgs :: HasDebugCallStack => Type -> [PrimRep] typePrimRepArgs ty | [] <- reps = [VoidRep] @@ -472,7 +472,9 @@ (typeKind ty) -- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output; --- an empty list of PrimReps becomes a VoidRep +-- an empty list of PrimReps becomes a VoidRep. +-- This assumption holds after unarise, see Note [Post-unarisation invariants]. +-- Before unarise it may or may not hold. -- See also Note [RuntimeRep and PrimRep] and Note [VoidRep] typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep typePrimRep1 ty = case typePrimRep ty of diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -1978,7 +1978,7 @@ -- | Returns free variables of a bag of constraints as a composable FV -- computation. See Note [Deterministic FV] in FV. tyCoFVsOfCts :: Cts -> FV -tyCoFVsOfCts = foldrBag (unionFV . tyCoFVsOfCt) emptyFV +tyCoFVsOfCts = foldr (unionFV . tyCoFVsOfCt) emptyFV -- | Returns free variables of WantedConstraints as a non-deterministic -- set. See Note [Deterministic FV] in FV. @@ -2015,7 +2015,7 @@ tyCoFVsOfWC wanted tyCoFVsOfBag :: (a -> FV) -> Bag a -> FV -tyCoFVsOfBag tvs_of = foldrBag (unionFV . tvs_of) emptyFV +tyCoFVsOfBag tvs_of = foldr (unionFV . tvs_of) emptyFV --------------------------- dropDerivedWC :: WantedConstraints -> WantedConstraints @@ -2525,7 +2525,7 @@ ppr_bag doc bag | isEmptyBag bag = empty | otherwise = hang (doc <+> equals) - 2 (foldrBag (($$) . ppr) empty bag) + 2 (foldr (($$) . ppr) empty bag) {- Note [Given insolubles] ~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/utils/Bag.hs b/compiler/utils/Bag.hs --- a/compiler/utils/Bag.hs +++ b/compiler/utils/Bag.hs @@ -15,11 +15,11 @@ mapBag, elemBag, lengthBag, filterBag, partitionBag, partitionBagWith, - concatBag, catBagMaybes, foldBag, foldrBag, foldlBag, + concatBag, catBagMaybes, foldBag, isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag, listToBag, bagToList, mapAccumBagL, concatMapBag, concatMapBagPair, mapMaybeBag, - foldrBagM, foldlBagM, mapBagM, mapBagM_, + mapBagM, mapBagM_, flatMapBagM, flatMapBagPairM, mapAndUnzipBagM, mapAccumBagLM, anyBagM, filterBagM @@ -134,12 +134,12 @@ anyBagM p (ListBag xs) = anyM p xs concatBag :: Bag (Bag a) -> Bag a -concatBag bss = foldrBag add emptyBag bss +concatBag bss = foldr add emptyBag bss where add bs rs = bs `unionBags` rs catBagMaybes :: Bag (Maybe a) -> Bag a -catBagMaybes bs = foldrBag add emptyBag bs +catBagMaybes bs = foldr add emptyBag bs where add Nothing rs = rs add (Just x) rs = x `consBag` rs @@ -191,36 +191,6 @@ foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1 foldBag t u e (ListBag xs) = foldr (t.u) e xs -foldrBag :: (a -> r -> r) -> r - -> Bag a - -> r - -foldrBag _ z EmptyBag = z -foldrBag k z (UnitBag x) = k x z -foldrBag k z (TwoBags b1 b2) = foldrBag k (foldrBag k z b2) b1 -foldrBag k z (ListBag xs) = foldr k z xs - -foldlBag :: (r -> a -> r) -> r - -> Bag a - -> r - -foldlBag _ z EmptyBag = z -foldlBag k z (UnitBag x) = k z x -foldlBag k z (TwoBags b1 b2) = foldlBag k (foldlBag k z b1) b2 -foldlBag k z (ListBag xs) = foldl k z xs - -foldrBagM :: (Monad m) => (a -> b -> m b) -> b -> Bag a -> m b -foldrBagM _ z EmptyBag = return z -foldrBagM k z (UnitBag x) = k x z -foldrBagM k z (TwoBags b1 b2) = do { z' <- foldrBagM k z b2; foldrBagM k z' b1 } -foldrBagM k z (ListBag xs) = foldrM k z xs - -foldlBagM :: (Monad m) => (b -> a -> m b) -> b -> Bag a -> m b -foldlBagM _ z EmptyBag = return z -foldlBagM k z (UnitBag x) = k z x -foldlBagM k z (TwoBags b1 b2) = do { z' <- foldlBagM k z b1; foldlBagM k z' b2 } -foldlBagM k z (ListBag xs) = foldlM k z xs - mapBag :: (a -> b) -> Bag a -> Bag b mapBag = fmap @@ -330,7 +300,7 @@ listToBag vs = ListBag vs bagToList :: Bag a -> [a] -bagToList b = foldrBag (:) [] b +bagToList b = foldr (:) [] b instance (Outputable a) => Outputable (Bag a) where ppr bag = braces (pprWithCommas ppr (bagToList bag)) @@ -343,4 +313,17 @@ dataCast1 x = gcast1 x instance Foldable.Foldable Bag where - foldr = foldrBag + foldr _ z EmptyBag = z + foldr k z (UnitBag x) = k x z + foldr k z (TwoBags b1 b2) = foldr k (foldr k z b2) b1 + foldr k z (ListBag xs) = foldr k z xs + + foldl _ z EmptyBag = z + foldl k z (UnitBag x) = k z x + foldl k z (TwoBags b1 b2) = foldl k (foldl k z b1) b2 + foldl k z (ListBag xs) = foldl k z xs + + foldl' _ z EmptyBag = z + foldl' k z (UnitBag x) = k z x + foldl' k z (TwoBags b1 b2) = let r1 = foldl' k z b1 in seq r1 $ foldl' k r1 b2 + foldl' k z (ListBag xs) = foldl' k z xs diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -4,6 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -O2 -funbox-strict-fields #-} -- We always optimise this, otherwise performance of a non-optimised @@ -45,6 +46,12 @@ putByte, getByte, + -- * Variable length encodings + putULEB128, + getULEB128, + putSLEB128, + getSLEB128, + -- * Lazy Binary I/O lazyGet, lazyPut, @@ -79,11 +86,12 @@ import Data.IORef import Data.Char ( ord, chr ) import Data.Time +import Data.List (unfoldr) import Type.Reflection import Type.Reflection.Unsafe import Data.Kind (Type) import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..)) -import Control.Monad ( when ) +import Control.Monad ( when, (<$!>), unless ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO.Error ( mkIOError, eofErrorType ) @@ -138,6 +146,8 @@ -- class Binary --------------------------------------------------------------- +-- | Do not rely on instance sizes for general types, +-- we use variable length encoding for many of them. class Binary a where put_ :: BinHandle -> a -> IO () put :: BinHandle -> a -> IO (Bin a) @@ -171,14 +181,14 @@ tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) seekBin :: BinHandle -> Bin a -> IO () -seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do +seekBin h@(BinMem _ ix_r sz_r _) (BinPtr !p) = do sz <- readFastMutInt sz_r if (p >= sz) then do expandBin h p; writeFastMutInt ix_r p else writeFastMutInt ix_r p seekBy :: BinHandle -> Int -> IO () -seekBy h@(BinMem _ ix_r sz_r _) off = do +seekBy h@(BinMem _ ix_r sz_r _) !off = do sz <- readFastMutInt sz_r ix <- readFastMutInt ix_r let ix' = ix + off @@ -220,9 +230,9 @@ -- expand the size of the array to include a specified offset expandBin :: BinHandle -> Int -> IO () -expandBin (BinMem _ _ sz_r arr_r) off = do - sz <- readFastMutInt sz_r - let sz' = head (dropWhile (<= off) (iterate (* 2) sz)) +expandBin (BinMem _ _ sz_r arr_r) !off = do + !sz <- readFastMutInt sz_r + let !sz' = getSize sz arr <- readIORef arr_r arr' <- mallocForeignPtrBytes sz' withForeignPtr arr $ \old -> @@ -230,10 +240,20 @@ copyBytes new old sz writeFastMutInt sz_r sz' writeIORef arr_r arr' + where + getSize :: Int -> Int + getSize !sz + | sz > off + = sz + | otherwise + = getSize (sz * 2) -- ----------------------------------------------------------------------------- -- Low-level reading/writing of bytes +-- | Takes a size and action writing up to @size@ bytes. +-- After the action has run advance the index to the buffer +-- by size bytes. putPrim :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO () putPrim h@(BinMem _ ix_r sz_r arr_r) size f = do ix <- readFastMutInt ix_r @@ -244,6 +264,18 @@ withForeignPtr arr $ \op -> f (op `plusPtr` ix) writeFastMutInt ix_r (ix + size) +-- -- | Similar to putPrim but advances the index by the actual number of +-- -- bytes written. +-- putPrimMax :: BinHandle -> Int -> (Ptr Word8 -> IO Int) -> IO () +-- putPrimMax h@(BinMem _ ix_r sz_r arr_r) size f = do +-- ix <- readFastMutInt ix_r +-- sz <- readFastMutInt sz_r +-- when (ix + size > sz) $ +-- expandBin h (ix + size) +-- arr <- readIORef arr_r +-- written <- withForeignPtr arr $ \op -> f (op `plusPtr` ix) +-- writeFastMutInt ix_r (ix + written) + getPrim :: BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a getPrim (BinMem _ ix_r sz_r arr_r) size f = do ix <- readFastMutInt ix_r @@ -256,23 +288,23 @@ return w putWord8 :: BinHandle -> Word8 -> IO () -putWord8 h w = putPrim h 1 (\op -> poke op w) +putWord8 h !w = putPrim h 1 (\op -> poke op w) getWord8 :: BinHandle -> IO Word8 getWord8 h = getPrim h 1 peek -putWord16 :: BinHandle -> Word16 -> IO () -putWord16 h w = putPrim h 2 (\op -> do - pokeElemOff op 0 (fromIntegral (w `shiftR` 8)) - pokeElemOff op 1 (fromIntegral (w .&. 0xFF)) - ) +-- putWord16 :: BinHandle -> Word16 -> IO () +-- putWord16 h w = putPrim h 2 (\op -> do +-- pokeElemOff op 0 (fromIntegral (w `shiftR` 8)) +-- pokeElemOff op 1 (fromIntegral (w .&. 0xFF)) +-- ) -getWord16 :: BinHandle -> IO Word16 -getWord16 h = getPrim h 2 (\op -> do - w0 <- fromIntegral <$> peekElemOff op 0 - w1 <- fromIntegral <$> peekElemOff op 1 - return $! w0 `shiftL` 8 .|. w1 - ) +-- getWord16 :: BinHandle -> IO Word16 +-- getWord16 h = getPrim h 2 (\op -> do +-- w0 <- fromIntegral <$> peekElemOff op 0 +-- w1 <- fromIntegral <$> peekElemOff op 1 +-- return $! w0 `shiftL` 8 .|. w1 +-- ) putWord32 :: BinHandle -> Word32 -> IO () putWord32 h w = putPrim h 4 (\op -> do @@ -295,63 +327,188 @@ w3 ) -putWord64 :: BinHandle -> Word64 -> IO () -putWord64 h w = putPrim h 8 (\op -> do - pokeElemOff op 0 (fromIntegral (w `shiftR` 56)) - pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF)) - pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF)) - pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF)) - pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF)) - pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) - pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) - pokeElemOff op 7 (fromIntegral (w .&. 0xFF)) - ) +-- putWord64 :: BinHandle -> Word64 -> IO () +-- putWord64 h w = putPrim h 8 (\op -> do +-- pokeElemOff op 0 (fromIntegral (w `shiftR` 56)) +-- pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF)) +-- pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF)) +-- pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF)) +-- pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF)) +-- pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) +-- pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) +-- pokeElemOff op 7 (fromIntegral (w .&. 0xFF)) +-- ) -getWord64 :: BinHandle -> IO Word64 -getWord64 h = getPrim h 8 (\op -> do - w0 <- fromIntegral <$> peekElemOff op 0 - w1 <- fromIntegral <$> peekElemOff op 1 - w2 <- fromIntegral <$> peekElemOff op 2 - w3 <- fromIntegral <$> peekElemOff op 3 - w4 <- fromIntegral <$> peekElemOff op 4 - w5 <- fromIntegral <$> peekElemOff op 5 - w6 <- fromIntegral <$> peekElemOff op 6 - w7 <- fromIntegral <$> peekElemOff op 7 +-- getWord64 :: BinHandle -> IO Word64 +-- getWord64 h = getPrim h 8 (\op -> do +-- w0 <- fromIntegral <$> peekElemOff op 0 +-- w1 <- fromIntegral <$> peekElemOff op 1 +-- w2 <- fromIntegral <$> peekElemOff op 2 +-- w3 <- fromIntegral <$> peekElemOff op 3 +-- w4 <- fromIntegral <$> peekElemOff op 4 +-- w5 <- fromIntegral <$> peekElemOff op 5 +-- w6 <- fromIntegral <$> peekElemOff op 6 +-- w7 <- fromIntegral <$> peekElemOff op 7 - return $! (w0 `shiftL` 56) .|. - (w1 `shiftL` 48) .|. - (w2 `shiftL` 40) .|. - (w3 `shiftL` 32) .|. - (w4 `shiftL` 24) .|. - (w5 `shiftL` 16) .|. - (w6 `shiftL` 8) .|. - w7 - ) +-- return $! (w0 `shiftL` 56) .|. +-- (w1 `shiftL` 48) .|. +-- (w2 `shiftL` 40) .|. +-- (w3 `shiftL` 32) .|. +-- (w4 `shiftL` 24) .|. +-- (w5 `shiftL` 16) .|. +-- (w6 `shiftL` 8) .|. +-- w7 +-- ) putByte :: BinHandle -> Word8 -> IO () -putByte bh w = putWord8 bh w +putByte bh !w = putWord8 bh w getByte :: BinHandle -> IO Word8 getByte h = getWord8 h -- ----------------------------------------------------------------------------- +-- Encode numbers in LEB128 encoding. +-- Requires one byte of space per 7 bits of data. +-- +-- There are signed and unsigned variants. +-- Do NOT use the unsigned one for signed values, at worst it will +-- result in wrong results, at best it will lead to bad performance +-- when coercing negative values to an unsigned type. +-- +-- We mark them as SPECIALIZE as it's extremely critical that they get specialized +-- to their specific types. +-- +-- TODO: Each use of putByte performs a bounds check, +-- we should use putPrimMax here. However it's quite hard to return +-- the number of bytes written into putPrimMax without allocating an +-- Int for it, while the code below does not allocate at all. +-- So we eat the cost of the bounds check instead of increasing allocations +-- for now. + +-- Unsigned numbers +{-# SPECIALISE putULEB128 :: BinHandle -> Word -> IO () #-} +{-# SPECIALISE putULEB128 :: BinHandle -> Word64 -> IO () #-} +{-# SPECIALISE putULEB128 :: BinHandle -> Word32 -> IO () #-} +{-# SPECIALISE putULEB128 :: BinHandle -> Word16 -> IO () #-} +{-# SPECIALISE putULEB128 :: BinHandle -> Int -> IO () #-} +{-# SPECIALISE putULEB128 :: BinHandle -> Int64 -> IO () #-} +{-# SPECIALISE putULEB128 :: BinHandle -> Int32 -> IO () #-} +{-# SPECIALISE putULEB128 :: BinHandle -> Int16 -> IO () #-} +putULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> a -> IO () +putULEB128 bh w = +#if defined(DEBUG) + (if w < 0 then panic "putULEB128: Signed number" else id) $ +#endif + go w + where + go :: a -> IO () + go w + | w <= (127 :: a) + = putByte bh (fromIntegral w :: Word8) + | otherwise = do + -- bit 7 (8th bit) indicates more to come. + let !byte = setBit (fromIntegral w) 7 :: Word8 + putByte bh byte + go (w `unsafeShiftR` 7) + +{-# SPECIALISE getULEB128 :: BinHandle -> IO Word #-} +{-# SPECIALISE getULEB128 :: BinHandle -> IO Word64 #-} +{-# SPECIALISE getULEB128 :: BinHandle -> IO Word32 #-} +{-# SPECIALISE getULEB128 :: BinHandle -> IO Word16 #-} +{-# SPECIALISE getULEB128 :: BinHandle -> IO Int #-} +{-# SPECIALISE getULEB128 :: BinHandle -> IO Int64 #-} +{-# SPECIALISE getULEB128 :: BinHandle -> IO Int32 #-} +{-# SPECIALISE getULEB128 :: BinHandle -> IO Int16 #-} +getULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> IO a +getULEB128 bh = + go 0 0 + where + go :: Int -> a -> IO a + go shift w = do + b <- getByte bh + let !hasMore = testBit b 7 + let !val = w .|. ((clearBit (fromIntegral b) 7) `unsafeShiftL` shift) :: a + if hasMore + then do + go (shift+7) val + else + return $! val + +-- Signed numbers +{-# SPECIALISE putSLEB128 :: BinHandle -> Word -> IO () #-} +{-# SPECIALISE putSLEB128 :: BinHandle -> Word64 -> IO () #-} +{-# SPECIALISE putSLEB128 :: BinHandle -> Word32 -> IO () #-} +{-# SPECIALISE putSLEB128 :: BinHandle -> Word16 -> IO () #-} +{-# SPECIALISE putSLEB128 :: BinHandle -> Int -> IO () #-} +{-# SPECIALISE putSLEB128 :: BinHandle -> Int64 -> IO () #-} +{-# SPECIALISE putSLEB128 :: BinHandle -> Int32 -> IO () #-} +{-# SPECIALISE putSLEB128 :: BinHandle -> Int16 -> IO () #-} +putSLEB128 :: forall a. (Integral a, Bits a) => BinHandle -> a -> IO () +putSLEB128 bh initial = go initial + where + go :: a -> IO () + go val = do + let !byte = fromIntegral (clearBit val 7) :: Word8 + let !val' = val `unsafeShiftR` 7 + let !signBit = testBit byte 6 + let !done = + -- Unsigned value, val' == 0 and and last value can + -- be discriminated from a negative number. + ((val' == 0 && not signBit) || + -- Signed value, + (val' == -1 && signBit)) + + let !byte' = if done then byte else setBit byte 7 + putByte bh byte' + + unless done $ go val' + +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word #-} +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word64 #-} +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word32 #-} +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word16 #-} +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int #-} +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int64 #-} +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int32 #-} +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int16 #-} +getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => BinHandle -> IO a +getSLEB128 bh = do + (val,shift,signed) <- go 0 0 + if signed && (shift < finiteBitSize val ) + then return $! ((complement 0 `unsafeShiftL` shift) .|. val) + else return val + where + go :: Int -> a -> IO (a,Int,Bool) + go shift val = do + byte <- getByte bh + let !byteVal = fromIntegral (clearBit byte 7) :: a + let !val' = val .|. (byteVal `unsafeShiftL` shift) + let !more = testBit byte 7 + let !shift' = shift+7 + if more + then go (shift') val' + else do + let !signed = testBit byte 6 + return (val',shift',signed) + +-- ----------------------------------------------------------------------------- -- Primitive Word writes instance Binary Word8 where - put_ = putWord8 + put_ bh !w = putWord8 bh w get = getWord8 instance Binary Word16 where - put_ h w = putWord16 h w - get h = getWord16 h + put_ = putULEB128 + get = getULEB128 instance Binary Word32 where - put_ h w = putWord32 h w - get h = getWord32 h + put_ = putULEB128 + get = getULEB128 instance Binary Word64 where - put_ h w = putWord64 h w - get h = getWord64 h + put_ = putULEB128 + get = getULEB128 -- ----------------------------------------------------------------------------- -- Primitive Int writes @@ -361,16 +518,16 @@ get h = do w <- get h; return $! (fromIntegral (w::Word8)) instance Binary Int16 where - put_ h w = put_ h (fromIntegral w :: Word16) - get h = do w <- get h; return $! (fromIntegral (w::Word16)) + put_ = putSLEB128 + get = getSLEB128 instance Binary Int32 where - put_ h w = put_ h (fromIntegral w :: Word32) - get h = do w <- get h; return $! (fromIntegral (w::Word32)) + put_ = putSLEB128 + get = getSLEB128 instance Binary Int64 where - put_ h w = put_ h (fromIntegral w :: Word64) - get h = do w <- get h; return $! (fromIntegral (w::Word64)) + put_ h w = putSLEB128 h w + get h = getSLEB128 h -- ----------------------------------------------------------------------------- -- Instances for standard types @@ -396,15 +553,11 @@ instance Binary a => Binary [a] where put_ bh l = do let len = length l - if (len < 0xff) - then putByte bh (fromIntegral len :: Word8) - else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32) + put_ bh len mapM_ (put_ bh) l get bh = do - b <- getByte bh - len <- if b == 0xff - then get bh - else return (fromIntegral b :: Word32) + len <- get bh :: IO Int -- Int is variable length encoded so only + -- one byte for small lists. let loop 0 = return [] loop n = do a <- get bh; as <- loop (n-1); return (a:as) loop len @@ -502,41 +655,89 @@ get bh = do r <- get bh return $ fromRational r ---to quote binary-0.3 on this code idea, --- --- TODO This instance is not architecture portable. GMP stores numbers as --- arrays of machine sized words, so the byte format is not portable across --- architectures with different endianness and word size. --- --- This makes it hard (impossible) to make an equivalent instance --- with code that is compilable with non-GHC. Do we need any instance --- Binary Integer, and if so, does it have to be blazing fast? Or can --- we just change this instance to be portable like the rest of the --- instances? (binary package has code to steal for that) --- --- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.hs +{- +Finally - a reasonable portable Integer instance. +We used to encode values in the Int32 range as such, +falling back to a string of all things. In either case +we stored a tag byte to discriminate between the two cases. + +This made some sense as it's highly portable but also not very +efficient. + +However GHC stores a surprisingly large number off large Integer +values. In the examples looked at between 25% and 50% of Integers +serialized were outside of the Int32 range. + +Consider a valie like `2724268014499746065`, some sort of hash +actually generated by GHC. +In the old scheme this was encoded as a list of 19 chars. This +gave a size of 77 Bytes, one for the length of the list and 76 +since we encod chars as Word32 as well. + +We can easily do better. The new plan is: + +* Start with a tag byte + * 0 => Int64 (LEB128 encoded) + * 1 => Negative large interger + * 2 => Positive large integer +* Followed by the value: + * Int64 is encoded as usual + * Large integers are encoded as a list of bytes (Word8). + We use Data.Bits which defines a bit order independent of the representation. + Values are stored LSB first. + +This means our example value `2724268014499746065` is now only 10 bytes large. +* One byte tag +* One byte for the length of the [Word8] list. +* 8 bytes for the actual date. + +The new scheme also does not depend in any way on +architecture specific details. + +We still use this scheme even with LEB128 available, +as it has less overhead for truely large numbers. (> maxBound :: Int64) + +The instance is used for in Binary Integer and Binary Rational in basicTypes/Literal.hs +-} + instance Binary Integer where put_ bh i - | i >= lo32 && i <= hi32 = do + | i >= lo64 && i <= hi64 = do putWord8 bh 0 - put_ bh (fromIntegral i :: Int32) + put_ bh (fromIntegral i :: Int64) | otherwise = do - putWord8 bh 1 - put_ bh (show i) + if i < 0 + then putWord8 bh 1 + else putWord8 bh 2 + put_ bh (unroll $ abs i) where - lo32 = fromIntegral (minBound :: Int32) - hi32 = fromIntegral (maxBound :: Int32) - + lo64 = fromIntegral (minBound :: Int64) + hi64 = fromIntegral (maxBound :: Int64) get bh = do int_kind <- getWord8 bh case int_kind of - 0 -> fromIntegral <$> (get bh :: IO Int32) - _ -> do str <- get bh - case reads str of - [(i, "")] -> return i - _ -> fail ("Binary integer: got " ++ show str) + 0 -> fromIntegral <$!> (get bh :: IO Int64) + -- Large integer + 1 -> negate <$!> getInt + 2 -> getInt + _ -> panic "Binary Integer - Invalid byte" + where + getInt :: IO Integer + getInt = roll <$!> (get bh :: IO [Word8]) +unroll :: Integer -> [Word8] +unroll = unfoldr step + where + step 0 = Nothing + step i = Just (fromIntegral i, i `shiftR` 8) + +roll :: [Word8] -> Integer +roll = foldl' unstep 0 . reverse + where + unstep a b = a `shiftL` 8 .|. fromIntegral b + + {- -- This code is currently commented out. -- See https://gitlab.haskell.org/ghc/ghc/issues/3379#note_104346 for @@ -608,9 +809,11 @@ put_ bh (a :% b) = do put_ bh a; put_ bh b get bh = do a <- get bh; b <- get bh; return (a :% b) +-- Instance uses fixed-width encoding to allow inserting +-- Bin placeholders in the stream. instance Binary (Bin a) where - put_ bh (BinPtr i) = put_ bh (fromIntegral i :: Int32) - get bh = do i <- get bh; return (BinPtr (fromIntegral (i :: Int32))) + put_ bh (BinPtr i) = putWord32 bh (fromIntegral i :: Word32) + get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32))) -- ----------------------------------------------------------------------------- -- Instances for Data.Typeable stuff diff --git a/compiler/utils/Fingerprint.hsc b/compiler/utils/Fingerprint.hsc deleted file mode 100644 --- a/compiler/utils/Fingerprint.hsc +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE CPP #-} - --- ---------------------------------------------------------------------------- --- --- (c) The University of Glasgow 2006 --- --- Fingerprints for recompilation checking and ABI versioning. --- --- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance --- --- ---------------------------------------------------------------------------- - -module Fingerprint ( - readHexFingerprint, - fingerprintByteString, - -- * Re-exported from GHC.Fingerprint - Fingerprint(..), fingerprint0, - fingerprintFingerprints, - fingerprintData, - fingerprintString, - getFileHash - ) where - -#include "md5.h" -##include "HsVersions.h" - -import GhcPrelude - -import Foreign -import GHC.IO -import Numeric ( readHex ) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Unsafe as BS - -import GHC.Fingerprint - --- useful for parsing the output of 'md5sum', should we want to do that. -readHexFingerprint :: String -> Fingerprint -readHexFingerprint s = Fingerprint w1 w2 - where (s1,s2) = splitAt 16 s - [(w1,"")] = readHex s1 - [(w2,"")] = readHex (take 16 s2) - -fingerprintByteString :: BS.ByteString -> Fingerprint -fingerprintByteString bs = unsafeDupablePerformIO $ - BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> fingerprintData (castPtr ptr) len diff --git a/compiler/utils/MonadUtils.hs b/compiler/utils/MonadUtils.hs --- a/compiler/utils/MonadUtils.hs +++ b/compiler/utils/MonadUtils.hs @@ -32,7 +32,7 @@ import Control.Monad import Control.Monad.Fix import Control.Monad.IO.Class -import Data.Foldable (sequenceA_) +import Data.Foldable (sequenceA_, foldlM, foldrM) import Data.List (unzip4, unzip5, zipWith4) ------------------------------------------------------------------------------- @@ -190,18 +190,9 @@ orM :: Monad m => m Bool -> m Bool -> m Bool orM m1 m2 = m1 >>= \x -> if x then return True else m2 --- | Monadic version of foldl -foldlM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a -foldlM = foldM - -- | Monadic version of foldl that discards its result -foldlM_ :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m () +foldlM_ :: (Monad m, Foldable t) => (a -> b -> m a) -> a -> t b -> m () foldlM_ = foldM_ - --- | Monadic version of foldr -foldrM :: (Monad m) => (b -> a -> m a) -> a -> [b] -> m a -foldrM _ z [] = return z -foldrM k z (x:xs) = do { r <- foldrM k z xs; k x r } -- | Monadic version of fmap specialised for Maybe maybeMapM :: Monad m => (a -> m b) -> (Maybe a -> m (Maybe b)) diff --git a/compiler/utils/UniqDFM.hs b/compiler/utils/UniqDFM.hs --- a/compiler/utils/UniqDFM.hs +++ b/compiler/utils/UniqDFM.hs @@ -17,6 +17,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wall #-} module UniqDFM ( @@ -137,6 +138,16 @@ {-# UNPACK #-} !Int -- Upper bound on the values' insertion -- time. See Note [Overflow on plusUDFM] deriving (Data, Functor) + +-- | Deterministic, in O(n log n). +instance Foldable UniqDFM where + foldr = foldUDFM + +-- | Deterministic, in O(n log n). +instance Traversable UniqDFM where + traverse f = fmap listToUDFM_Directly + . traverse (\(u,a) -> (u,) <$> f a) + . udfmToList emptyUDFM :: UniqDFM elt emptyUDFM = UDFM M.empty 0 diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs --- a/compiler/utils/UniqFM.hs +++ b/compiler/utils/UniqFM.hs @@ -26,7 +26,8 @@ module UniqFM ( -- * Unique-keyed mappings - UniqFM, -- abstract type + UniqFM, -- abstract type + NonDetUniqFM(..), -- wrapper for opting into nondeterminism -- ** Manipulating those mappings emptyUFM, @@ -84,9 +85,8 @@ newtype UniqFM ele = UFM (M.IntMap ele) deriving (Data, Eq, Functor) - -- We used to derive Traversable and Foldable, but they were nondeterministic - -- and not obvious at the call site. You can use explicit nonDetEltsUFM - -- and fold a list if needed. + -- Nondeterministic Foldable and Traversable instances are accessible through + -- use of the 'NonDetUniqFM' wrapper. -- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism. emptyUFM :: UniqFM elt @@ -332,6 +332,29 @@ -- nondeterminism. nonDetUFMToList :: UniqFM elt -> [(Unique, elt)] nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m + +-- | A wrapper around 'UniqFM' with the sole purpose of informing call sites +-- that the provided 'Foldable' and 'Traversable' instances are +-- nondeterministic. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +-- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism. +newtype NonDetUniqFM ele = NonDetUniqFM { getNonDet :: UniqFM ele } + deriving (Functor) + +-- | Inherently nondeterministic. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +-- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism. +instance Foldable NonDetUniqFM where + foldr f z (NonDetUniqFM (UFM m)) = foldr f z m + +-- | Inherently nondeterministic. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +-- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism. +instance Traversable NonDetUniqFM where + traverse f (NonDetUniqFM (UFM m)) = NonDetUniqFM . UFM <$> traverse f m ufmToIntMap :: UniqFM elt -> M.IntMap elt ufmToIntMap (UFM m) = m diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs --- a/compiler/utils/Util.hs +++ b/compiler/utils/Util.hs @@ -1123,22 +1123,16 @@ ----------------------------------------------------------------------------- -- Integers --- This algorithm for determining the $\log_2$ of exact powers of 2 comes --- from GCC. It requires bit manipulation primitives, and we use GHC --- extensions. Tough. - +-- | Determine the $\log_2$ of exact powers of 2 exactLog2 :: Integer -> Maybe Integer exactLog2 x - = if (x <= 0 || x >= 2147483648) then - Nothing - else - if (x .&. (-x)) /= x then - Nothing - else - Just (pow2 x) - where - pow2 x | x == 1 = 0 - | otherwise = 1 + pow2 (x `shiftR` 1) + | x <= 0 = Nothing + | x > fromIntegral (maxBound :: Int32) = Nothing + | x' .&. (-x') /= x' = Nothing + | otherwise = Just (fromIntegral c) + where + x' = fromIntegral x :: Int32 + c = countTrailingZeros x' {- -- ----------------------------------------------------------------------------- diff --git a/ghc-lib-parser.cabal b/ghc-lib-parser.cabal --- a/ghc-lib-parser.cabal +++ b/ghc-lib-parser.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-parser -version: 0.20190806 +version: 0.20190903 license: BSD3 license-file: LICENSE category: Development @@ -128,8 +128,6 @@ compiler/parser/cutils.c hs-source-dirs: ghc-lib/stage0/libraries/ghc-boot/build - ghc-lib/stage0/libraries/ghc-heap/build - ghc-lib/stage0/libraries/ghci/build ghc-lib/stage0/compiler/build ghc-lib/stage1/compiler/build libraries/template-haskell diff --git a/ghc-lib/generated/ghcversion.h b/ghc-lib/generated/ghcversion.h --- a/ghc-lib/generated/ghcversion.h +++ b/ghc-lib/generated/ghcversion.h @@ -6,7 +6,7 @@ #endif #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0 -#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190804 +#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190902 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \ diff --git a/ghc-lib/stage0/compiler/build/Parser.hs b/ghc-lib/stage0/compiler/build/Parser.hs --- a/ghc-lib/stage0/compiler/build/Parser.hs +++ b/ghc-lib/stage0/compiler/build/Parser.hs @@ -12744,313 +12744,7 @@ {-# LINE 19 "" #-} -{-# LINE 1 "/var/folders/f_/bb4zyb7d2_z9bqm3hrqrjgp40000gn/T/ghc17116_0/ghc_2.h" #-} - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +{-# LINE 1 "/var/folders/kc/bjk2hzwx6bv07jz_s80wjh7w0000gn/T/ghc22993_0/ghc_2.h" #-} diff --git a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs --- a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +++ b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs @@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?] cProjectGitCommitId :: String -cProjectGitCommitId = "6e5dfcd2886d7523cfa059a64b343b22c5da4e97" +cProjectGitCommitId = "11679e5bec1994775072e8e60f24b4ce104af0a7" cProjectVersion :: String -cProjectVersion = "8.9.0.20190804" +cProjectVersion = "8.9.0.20190902" cProjectVersionInt :: String cProjectVersionInt = "809" cProjectPatchLevel :: String -cProjectPatchLevel = "020190804" +cProjectPatchLevel = "020190902" cProjectPatchLevel1 :: String cProjectPatchLevel1 = "0" cProjectPatchLevel2 :: String -cProjectPatchLevel2 = "20190804" +cProjectPatchLevel2 = "20190902" diff --git a/ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/Constants.hs b/ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/Constants.hs deleted file mode 100644 --- a/ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/Constants.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LINE 1 "libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc" #-} -{-# LANGUAGE CPP #-} - -module GHC.Exts.Heap.Constants - ( wORD_SIZE - , tAG_MASK - , wORD_SIZE_IN_BITS - ) where - - - -import Prelude -- See note [Why do we import Prelude here?] -import Data.Bits - -wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS :: Int -wORD_SIZE = 8 -{-# LINE 16 "libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc" #-} -wORD_SIZE_IN_BITS = 64 -{-# LINE 17 "libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc" #-} -tAG_MASK = (1 `shift` 3) - 1 -{-# LINE 18 "libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc" #-} diff --git a/ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/InfoTable.hs b/ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/InfoTable.hs deleted file mode 100644 --- a/ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/InfoTable.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LINE 1 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc" #-} -module GHC.Exts.Heap.InfoTable - ( module GHC.Exts.Heap.InfoTable.Types - , itblSize - , peekItbl - , pokeItbl - ) where - - - -import Prelude -- See note [Why do we import Prelude here?] -import GHC.Exts.Heap.InfoTable.Types - -{-# LINE 16 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc" #-} -import Foreign - -------------------------------------------------------------------------- --- Profiling specific code --- --- The functions that follow all rely on PROFILING. They are duplicated in --- ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc where PROFILING is defined. This --- allows hsc2hs to generate values for both profiling and non-profiling builds. - --- | Read an InfoTable from the heap into a haskell type. --- WARNING: This code assumes it is passed a pointer to a "standard" info --- table. If tables_next_to_code is enabled, it will look 1 byte before the --- start for the entry field. -peekItbl :: Ptr StgInfoTable -> IO StgInfoTable -peekItbl a0 = do - -{-# LINE 35 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc" #-} - let ptr = a0 - entry' = Nothing - -{-# LINE 38 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc" #-} - ptrs' <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr -{-# LINE 39 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc" #-} - nptrs' <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) ptr -{-# LINE 40 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc" #-} - tipe' <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr -{-# LINE 41 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc" #-} - -{-# LINE 42 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc" #-} - srtlen' <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) a0 -{-# LINE 43 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc" #-} - -{-# LINE 46 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc" #-} - return StgInfoTable - { entry = entry' - , ptrs = ptrs' - , nptrs = nptrs' - , tipe = toEnum (fromIntegral (tipe' :: HalfWord)) - , srtlen = srtlen' - , code = Nothing - } - -pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO () -pokeItbl a0 itbl = do - -{-# LINE 60 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) a0 (ptrs itbl) -{-# LINE 61 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) a0 (nptrs itbl) -{-# LINE 62 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) a0 (toHalfWord (fromEnum (tipe itbl))) -{-# LINE 63 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc" #-} - -{-# LINE 64 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) a0 (srtlen itbl) -{-# LINE 65 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc" #-} - -{-# LINE 68 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc" #-} - -{-# LINE 69 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc" #-} - let code_offset = a0 `plusPtr` ((16)) -{-# LINE 70 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc" #-} - case code itbl of - Nothing -> return () - Just (Left xs) -> pokeArray code_offset xs - Just (Right xs) -> pokeArray code_offset xs - -{-# LINE 75 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc" #-} - where - toHalfWord :: Int -> HalfWord - toHalfWord i = fromIntegral i - --- | Size in bytes of a standard InfoTable -itblSize :: Int -itblSize = ((16)) -{-# LINE 82 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc" #-} diff --git a/ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/InfoTable/Types.hs b/ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/InfoTable/Types.hs deleted file mode 100644 --- a/ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/InfoTable/Types.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LINE 1 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc" #-} -{-# LANGUAGE DeriveGeneric #-} -module GHC.Exts.Heap.InfoTable.Types - ( StgInfoTable(..) - , EntryFunPtr - , HalfWord - , ItblCodes - ) where - - - -import Prelude -- See note [Why do we import Prelude here?] -import GHC.Generics -import GHC.Exts.Heap.ClosureTypes -import Foreign - -type ItblCodes = Either [Word8] [Word32] - - --- Ultra-minimalist version specially for constructors - -{-# LINE 21 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc" #-} -type HalfWord = Word32 - -{-# LINE 27 "libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc" #-} - -type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ())) - --- | This is a somewhat faithful representation of an info table. See --- --- for more details on this data structure. -data StgInfoTable = StgInfoTable { - entry :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode - ptrs :: HalfWord, - nptrs :: HalfWord, - tipe :: ClosureType, - srtlen :: HalfWord, - code :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode - } deriving (Show, Generic) diff --git a/ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/InfoTableProf.hs b/ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/InfoTableProf.hs deleted file mode 100644 --- a/ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/InfoTableProf.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# OPTIONS_GHC -optc-DPROFILING #-} -{-# LINE 1 "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc" #-} -module GHC.Exts.Heap.InfoTableProf - ( module GHC.Exts.Heap.InfoTable.Types - , itblSize - , peekItbl - , pokeItbl - ) where - --- This file overrides InfoTable.hsc's implementation of peekItbl and pokeItbl. --- Manually defining PROFILING gives the #peek and #poke macros an accurate --- representation of StgInfoTable_ when hsc2hs runs. - - - -import Prelude -- See note [Why do we import Prelude here?] -import GHC.Exts.Heap.InfoTable.Types - -{-# LINE 20 "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc" #-} -import Foreign - --- | Read an InfoTable from the heap into a haskell type. --- WARNING: This code assumes it is passed a pointer to a "standard" info --- table. If tables_next_to_code is enabled, it will look 1 byte before the --- start for the entry field. -peekItbl :: Ptr StgInfoTable -> IO StgInfoTable -peekItbl a0 = do - -{-# LINE 32 "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc" #-} - let ptr = a0 - entry' = Nothing - -{-# LINE 35 "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc" #-} - ptrs' <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr -{-# LINE 36 "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc" #-} - nptrs' <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) ptr -{-# LINE 37 "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc" #-} - tipe' <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) ptr -{-# LINE 38 "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc" #-} - -{-# LINE 39 "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc" #-} - srtlen' <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) a0 -{-# LINE 40 "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc" #-} - -{-# LINE 43 "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc" #-} - return StgInfoTable - { entry = entry' - , ptrs = ptrs' - , nptrs = nptrs' - , tipe = toEnum (fromIntegral (tipe' :: HalfWord)) - , srtlen = srtlen' - , code = Nothing - } - -pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO () -pokeItbl a0 itbl = do - -{-# LINE 57 "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) a0 (ptrs itbl) -{-# LINE 58 "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) a0 (nptrs itbl) -{-# LINE 59 "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 24)) a0 (fromEnum (tipe itbl)) -{-# LINE 60 "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc" #-} - -{-# LINE 61 "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc" #-} - ((\hsc_ptr -> pokeByteOff hsc_ptr 28)) a0 (srtlen itbl) -{-# LINE 62 "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc" #-} - -{-# LINE 65 "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc" #-} - -{-# LINE 66 "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc" #-} - let code_offset = a0 `plusPtr` ((32)) -{-# LINE 67 "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc" #-} - case code itbl of - Nothing -> return () - Just (Left xs) -> pokeArray code_offset xs - Just (Right xs) -> pokeArray code_offset xs - -{-# LINE 72 "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc" #-} - -itblSize :: Int -itblSize = ((32)) -{-# LINE 75 "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc" #-} diff --git a/ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/Utils.hs b/ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/Utils.hs deleted file mode 100644 --- a/ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/Utils.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LINE 1 "libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc" #-} -{-# LANGUAGE CPP, MagicHash #-} - -module GHC.Exts.Heap.Utils ( - dataConNames - ) where - - - -import Prelude -- See note [Why do we import Prelude here?] -import GHC.Exts.Heap.Constants -import GHC.Exts.Heap.InfoTable - -import Data.Char -import Data.List -import Foreign -import GHC.CString -import GHC.Exts - -{- To find the string in the constructor's info table we need to consider - the layout of info tables relative to the entry code for a closure. - - An info table can be next to the entry code for the closure, or it can - be separate. The former (faster) is used in registerised versions of ghc, - and the latter (portable) is for non-registerised versions. - - The diagrams below show where the string is to be found relative to - the normal info table of the closure. - - 1) Tables next to code: - - -------------- - | | <- pointer to the start of the string - -------------- - | | <- the (start of the) info table structure - | | - | | - -------------- - | entry code | - | .... | - - In this case the pointer to the start of the string can be found in - the memory location _one word before_ the first entry in the normal info - table. - - 2) Tables NOT next to code: - - -------------- - info table structure -> | *------------------> -------------- - | | | entry code | - | | | .... | - -------------- - ptr to start of str -> | | - -------------- - - In this case the pointer to the start of the string can be found - in the memory location: info_table_ptr + info_table_size --} - --- Given a ptr to an 'StgInfoTable' for a data constructor --- return (Package, Module, Name) -dataConNames :: Ptr StgInfoTable -> IO (String, String, String) -dataConNames ptr = do - conDescAddress <- getConDescAddress - pure $ parse conDescAddress - where - -- Retrieve the con_desc field address pointing to - -- 'Package:Module.Name' string - getConDescAddress :: IO (Ptr Word8) - getConDescAddress - -{-# LINE 71 "libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc" #-} - = do - offsetToString <- peek (ptr `plusPtr` negate wORD_SIZE) - pure $ (ptr `plusPtr` stdInfoTableSizeB) - `plusPtr` fromIntegral (offsetToString :: Int32) - -{-# LINE 78 "libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc" #-} - - stdInfoTableSizeW :: Int - -- The size of a standard info table varies with profiling/ticky etc, - -- so we can't get it from Constants - -- It must vary in sync with mkStdInfoTable - stdInfoTableSizeW - = size_fixed + size_prof - where - size_fixed = 2 -- layout, type -#if defined(PROFILING) - size_prof = 2 -#else - size_prof = 0 -#endif - - stdInfoTableSizeB :: Int - stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE - --- parsing names is a little bit fiddly because we have a string in the form: --- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo"). --- Thus we split at the leftmost colon and the rightmost occurrence of the dot. --- It would be easier if the string was in the form pkg:A.B.C:foo, but alas --- this is not the conventional way of writing Haskell names. We stick with --- convention, even though it makes the parsing code more troublesome. --- Warning: this code assumes that the string is well formed. -parse :: Ptr Word8 -> (String, String, String) -parse (Ptr addr) = if not . all (>0) . fmap length $ [p,m,occ] - then ([], [], input) - else (p, m, occ) - where - input = unpackCStringUtf8# addr - (p, rest1) = break (== ':') input - (m, occ) - = (intercalate "." $ reverse modWords, occWord) - where - (modWords, occWord) = - if length rest1 < 1 -- XXXXXXXXx YUKX - --then error "getConDescAddress:parse:length rest1 < 1" - then parseModOcc [] [] - else parseModOcc [] (tail rest1) - -- We only look for dots if str could start with a module name, - -- i.e. if it starts with an upper case character. - -- Otherwise we might think that "X.:->" is the module name in - -- "X.:->.+", whereas actually "X" is the module name and - -- ":->.+" is a constructor name. - parseModOcc :: [String] -> String -> ([String], String) - parseModOcc acc str@(c : _) - | isUpper c = - case break (== '.') str of - (top, []) -> (acc, top) - (top, _:bot) -> parseModOcc (top : acc) bot - parseModOcc acc str = (acc, str) diff --git a/ghc-lib/stage0/libraries/ghci/build/GHCi/FFI.hs b/ghc-lib/stage0/libraries/ghci/build/GHCi/FFI.hs deleted file mode 100644 --- a/ghc-lib/stage0/libraries/ghci/build/GHCi/FFI.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LINE 1 "libraries/ghci/GHCi/FFI.hsc" #-} ------------------------------------------------------------------------------ --- --- libffi bindings --- --- (c) The University of Glasgow 2008 --- ------------------------------------------------------------------------------ - - - -{-# LANGUAGE CPP, DeriveGeneric, DeriveAnyClass #-} -module GHCi.FFI - ( FFIType(..) - , FFIConv(..) - , C_ffi_cif - , prepForeignCall - , freeForeignCallInfo - ) where - -import Prelude -- See note [Why do we import Prelude here?] -import Control.Exception -import Data.Binary -import GHC.Generics -import Foreign -import Foreign.C - -data FFIType - = FFIVoid - | FFIPointer - | FFIFloat - | FFIDouble - | FFISInt8 - | FFISInt16 - | FFISInt32 - | FFISInt64 - | FFIUInt8 - | FFIUInt16 - | FFIUInt32 - | FFIUInt64 - deriving (Show, Generic, Binary) - -data FFIConv - = FFICCall - | FFIStdCall - deriving (Show, Generic, Binary) - - -prepForeignCall - :: FFIConv - -> [FFIType] -- arg types - -> FFIType -- result type - -> IO (Ptr C_ffi_cif) -- token for making calls (must be freed by caller) - -prepForeignCall cconv arg_types result_type = do - let n_args = length arg_types - arg_arr <- mallocArray n_args - pokeArray arg_arr (map ffiType arg_types) - cif <- mallocBytes (32) -{-# LINE 59 "libraries/ghci/GHCi/FFI.hsc" #-} - let abi = convToABI cconv - r <- ffi_prep_cif cif abi (fromIntegral n_args) (ffiType result_type) arg_arr - if (r /= fFI_OK) - then throwIO (ErrorCall ("prepForeignCallFailed: " ++ show r)) - else return (castPtr cif) - -freeForeignCallInfo :: Ptr C_ffi_cif -> IO () -freeForeignCallInfo p = do - free (((\hsc_ptr -> hsc_ptr `plusPtr` 8)) p) -{-# LINE 68 "libraries/ghci/GHCi/FFI.hsc" #-} - free p - -convToABI :: FFIConv -> C_ffi_abi -convToABI FFICCall = fFI_DEFAULT_ABI - -{-# LINE 75 "libraries/ghci/GHCi/FFI.hsc" #-} --- unknown conventions are mapped to the default, (#3336) -convToABI _ = fFI_DEFAULT_ABI - -ffiType :: FFIType -> Ptr C_ffi_type -ffiType FFIVoid = ffi_type_void -ffiType FFIPointer = ffi_type_pointer -ffiType FFIFloat = ffi_type_float -ffiType FFIDouble = ffi_type_double -ffiType FFISInt8 = ffi_type_sint8 -ffiType FFISInt16 = ffi_type_sint16 -ffiType FFISInt32 = ffi_type_sint32 -ffiType FFISInt64 = ffi_type_sint64 -ffiType FFIUInt8 = ffi_type_uint8 -ffiType FFIUInt16 = ffi_type_uint16 -ffiType FFIUInt32 = ffi_type_uint32 -ffiType FFIUInt64 = ffi_type_uint64 - -data C_ffi_type -data C_ffi_cif - -type C_ffi_status = (Word32) -{-# LINE 96 "libraries/ghci/GHCi/FFI.hsc" #-} -type C_ffi_abi = (Word32) -{-# LINE 97 "libraries/ghci/GHCi/FFI.hsc" #-} - -foreign import ccall "&ffi_type_void" ffi_type_void :: Ptr C_ffi_type -foreign import ccall "&ffi_type_uint8" ffi_type_uint8 :: Ptr C_ffi_type -foreign import ccall "&ffi_type_sint8" ffi_type_sint8 :: Ptr C_ffi_type -foreign import ccall "&ffi_type_uint16" ffi_type_uint16 :: Ptr C_ffi_type -foreign import ccall "&ffi_type_sint16" ffi_type_sint16 :: Ptr C_ffi_type -foreign import ccall "&ffi_type_uint32" ffi_type_uint32 :: Ptr C_ffi_type -foreign import ccall "&ffi_type_sint32" ffi_type_sint32 :: Ptr C_ffi_type -foreign import ccall "&ffi_type_uint64" ffi_type_uint64 :: Ptr C_ffi_type -foreign import ccall "&ffi_type_sint64" ffi_type_sint64 :: Ptr C_ffi_type -foreign import ccall "&ffi_type_float" ffi_type_float :: Ptr C_ffi_type -foreign import ccall "&ffi_type_double" ffi_type_double :: Ptr C_ffi_type -foreign import ccall "&ffi_type_pointer"ffi_type_pointer :: Ptr C_ffi_type - -fFI_OK :: C_ffi_status -fFI_OK = (0) -{-# LINE 113 "libraries/ghci/GHCi/FFI.hsc" #-} ---fFI_BAD_ABI :: C_ffi_status ---fFI_BAD_ABI = (#const FFI_BAD_ABI) ---fFI_BAD_TYPEDEF :: C_ffi_status ---fFI_BAD_TYPEDEF = (#const FFI_BAD_TYPEDEF) - -fFI_DEFAULT_ABI :: C_ffi_abi -fFI_DEFAULT_ABI = (2) -{-# LINE 120 "libraries/ghci/GHCi/FFI.hsc" #-} - -{-# LINE 124 "libraries/ghci/GHCi/FFI.hsc" #-} - --- ffi_status ffi_prep_cif(ffi_cif *cif, --- ffi_abi abi, --- unsigned int nargs, --- ffi_type *rtype, --- ffi_type **atypes); - -foreign import ccall "ffi_prep_cif" - ffi_prep_cif :: Ptr C_ffi_cif -- cif - -> C_ffi_abi -- abi - -> CUInt -- nargs - -> Ptr C_ffi_type -- result type - -> Ptr (Ptr C_ffi_type) -- arg types - -> IO C_ffi_status - --- Currently unused: - --- void ffi_call(ffi_cif *cif, --- void (*fn)(), --- void *rvalue, --- void **avalue); - --- foreign import ccall "ffi_call" --- ffi_call :: Ptr C_ffi_cif -- cif --- -> FunPtr (IO ()) -- function to call --- -> Ptr () -- put result here --- -> Ptr (Ptr ()) -- arg values --- -> IO () diff --git a/libraries/ghc-boot/GHC/Platform.hs b/libraries/ghc-boot/GHC/Platform.hs --- a/libraries/ghc-boot/GHC/Platform.hs +++ b/libraries/ghc-boot/GHC/Platform.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase, ScopedTypeVariables #-} -- | A description of the platform we're compiling for. -- module GHC.Platform ( Platform(..), + PlatformWordSize(..), Arch(..), OS(..), ArmISA(..), @@ -17,6 +18,8 @@ osMachOTarget, osSubsectionsViaSymbols, platformUsesFrameworks, + platformWordSizeInBytes, + platformWordSizeInBits, PlatformMisc(..), IntegerLibrary(..), @@ -28,6 +31,7 @@ where import Prelude -- See Note [Why do we import Prelude here?] +import GHC.Read -- | Contains enough information for the native code generator to emit -- code for this platform. @@ -37,7 +41,7 @@ platformOS :: OS, -- Word size in bytes (i.e. normally 4 or 8, -- for 32bit and 64bit platforms respectively) - platformWordSize :: {-# UNPACK #-} !Int, + platformWordSize :: PlatformWordSize, platformUnregisterised :: Bool, platformHasGnuNonexecStack :: Bool, platformHasIdentDirective :: Bool, @@ -46,7 +50,32 @@ } deriving (Read, Show, Eq) +data PlatformWordSize + = PW4 -- ^ A 32-bit platform + | PW8 -- ^ A 64-bit platform + deriving (Eq) +instance Show PlatformWordSize where + show PW4 = "4" + show PW8 = "8" + +instance Read PlatformWordSize where + readPrec = do + i :: Int <- readPrec + case i of + 4 -> return PW4 + 8 -> return PW8 + other -> fail ("Invalid PlatformWordSize: " ++ show other) + +platformWordSizeInBytes :: Platform -> Int +platformWordSizeInBytes p = + case platformWordSize p of + PW4 -> 4 + PW8 -> 8 + +platformWordSizeInBits :: Platform -> Int +platformWordSizeInBits p = platformWordSizeInBytes p * 8 + -- | Architectures that the native code generator knows about. -- TODO: It might be nice to extend these constructors with information -- about what instruction set extensions an architecture might support. @@ -185,7 +214,10 @@ -- | This predicate tells us whether the platform is 32-bit. target32Bit :: Platform -> Bool -target32Bit p = platformWordSize p == 4 +target32Bit p = + case platformWordSize p of + PW4 -> True + PW8 -> False -- | This predicate tells us whether the OS supports ELF-like shared libraries. osElfTarget :: OS -> Bool @@ -237,6 +269,9 @@ , platformMisc_ghcWithNativeCodeGen :: Bool , platformMisc_ghcWithSMP :: Bool , platformMisc_ghcRTSWays :: String + -- | Determines whether we will be compiling info tables that reside just + -- before the entry code, or with an indirection to the entry code. See + -- TABLES_NEXT_TO_CODE in includes/rts/storage/InfoTables.h. , platformMisc_tablesNextToCode :: Bool , platformMisc_leadingUnderscore :: Bool , platformMisc_libFFI :: Bool diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -25,7 +25,7 @@ import Prelude -- See note [Why do we import Prelude here?] import GHCi.RemoteTypes import GHCi.FFI -import GHCi.TH.Binary () +import GHCi.TH.Binary () -- For Binary instances import GHCi.BreakArray import GHC.LanguageExtensions