ghc-lib-parser 0.20190806 → 0.20190903
raw patch · 35 files changed
+630/−1165 lines, 35 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Bag: foldlBag :: (r -> a -> r) -> r -> Bag a -> r
- Bag: foldlBagM :: Monad m => (b -> a -> m b) -> b -> Bag a -> m b
- Bag: foldrBag :: (a -> r -> r) -> r -> Bag a -> r
- Bag: foldrBagM :: Monad m => (a -> b -> m b) -> b -> Bag a -> m b
- DynFlags: Opt_D_dump_shape :: DumpFlag
- HsUtils: userHsLTyVarBndrs :: SrcSpan -> [Located (IdP (GhcPass p))] -> [LHsTyVarBndr (GhcPass p)]
- HsUtils: userHsTyVarBndrs :: SrcSpan -> [IdP (GhcPass p)] -> [LHsTyVarBndr (GhcPass p)]
+ Binary: getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => BinHandle -> IO a
+ Binary: getULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> IO a
+ Binary: putSLEB128 :: forall a. (Integral a, Bits a) => BinHandle -> a -> IO ()
+ Binary: putULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> a -> IO ()
+ DynFlags: Opt_PrintAxiomIncomps :: GeneralFlag
+ GHC.Platform: PW4 :: PlatformWordSize
+ GHC.Platform: PW8 :: PlatformWordSize
+ GHC.Platform: data PlatformWordSize
+ GHC.Platform: instance GHC.Classes.Eq GHC.Platform.PlatformWordSize
+ GHC.Platform: instance GHC.Read.Read GHC.Platform.PlatformWordSize
+ GHC.Platform: instance GHC.Show.Show GHC.Platform.PlatformWordSize
+ GHC.Platform: platformWordSizeInBits :: Platform -> Int
+ GHC.Platform: platformWordSizeInBytes :: Platform -> Int
+ UniqDFM: instance Data.Foldable.Foldable UniqDFM.UniqDFM
+ UniqDFM: instance Data.Traversable.Traversable UniqDFM.UniqDFM
+ UniqFM: NonDetUniqFM :: UniqFM ele -> NonDetUniqFM ele
+ UniqFM: [getNonDet] :: NonDetUniqFM ele -> UniqFM ele
+ UniqFM: instance Data.Foldable.Foldable UniqFM.NonDetUniqFM
+ UniqFM: instance Data.Traversable.Traversable UniqFM.NonDetUniqFM
+ UniqFM: instance GHC.Base.Functor UniqFM.NonDetUniqFM
+ UniqFM: newtype NonDetUniqFM ele
- GHC.Platform: Platform :: Arch -> OS -> {-# UNPACK #-} !Int -> Bool -> Bool -> Bool -> Bool -> Bool -> Platform
+ GHC.Platform: Platform :: Arch -> OS -> PlatformWordSize -> Bool -> Bool -> Bool -> Bool -> Bool -> Platform
- GHC.Platform: [platformWordSize] :: Platform -> {-# UNPACK #-} !Int
+ GHC.Platform: [platformWordSize] :: Platform -> PlatformWordSize
- MonadUtils: foldlM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a
+ MonadUtils: foldlM :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b
- MonadUtils: foldlM_ :: Monad m => (a -> b -> m a) -> a -> [b] -> m ()
+ MonadUtils: foldlM_ :: (Monad m, Foldable t) => (a -> b -> m a) -> a -> t b -> m ()
- MonadUtils: foldrM :: Monad m => (b -> a -> m a) -> a -> [b] -> m a
+ MonadUtils: foldrM :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b
- RepType: typePrimRepArgs :: Type -> [PrimRep]
+ RepType: typePrimRepArgs :: HasDebugCallStack => Type -> [PrimRep]
Files
- compiler/basicTypes/Literal.hs +32/−16
- compiler/coreSyn/CoreOpt.hs +79/−28
- compiler/coreSyn/CoreSubst.hs +0/−1
- compiler/coreSyn/CoreSyn.hs +10/−0
- compiler/coreSyn/CoreUnfold.hs +1/−2
- compiler/coreSyn/CoreUnfold.hs-boot +14/−0
- compiler/hsSyn/HsBinds.hs +0/−1
- compiler/hsSyn/HsSyn.hs +1/−1
- compiler/hsSyn/HsTypes.hs +0/−1
- compiler/hsSyn/HsUtils.hs +4/−15
- compiler/iface/IfaceSyn.hs +47/−15
- compiler/main/DynFlags.hs +12/−23
- compiler/main/HeaderInfo.hs +0/−1
- compiler/prelude/PrelRules.hs +11/−10
- compiler/simplStg/RepType.hs +4/−2
- compiler/typecheck/TcRnTypes.hs +3/−3
- compiler/utils/Bag.hs +19/−36
- compiler/utils/Binary.hs +299/−96
- compiler/utils/Fingerprint.hsc +0/−47
- compiler/utils/MonadUtils.hs +2/−11
- compiler/utils/UniqDFM.hs +11/−0
- compiler/utils/UniqFM.hs +27/−4
- compiler/utils/Util.hs +8/−14
- ghc-lib-parser.cabal +1/−3
- ghc-lib/generated/ghcversion.h +1/−1
- ghc-lib/stage0/compiler/build/Parser.hs +1/−307
- ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +4/−4
- ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/Constants.hs +0/−21
- ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/InfoTable.hs +0/−90
- ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/InfoTable/Types.hs +0/−39
- ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/InfoTableProf.hs +0/−84
- ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/Utils.hs +0/−130
- ghc-lib/stage0/libraries/ghci/build/GHCi/FFI.hs +0/−155
- libraries/ghc-boot/GHC/Platform.hs +38/−3
- libraries/ghci/GHCi/Message.hs +1/−1
compiler/basicTypes/Literal.hs view
@@ -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
compiler/coreSyn/CoreOpt.hs view
@@ -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 <body> , 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 <type> -> blah (and similarly for foralls) to keep this function simple. We could do more elaborate stuff, but it'd involve substitution etc.+ -}
compiler/coreSyn/CoreSubst.hs view
@@ -61,7 +61,6 @@ import Maybes import Util import Outputable-import PprCore () -- Instances import Data.List
compiler/coreSyn/CoreSyn.hs view
@@ -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.
compiler/coreSyn/CoreUnfold.hs view
@@ -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
+ compiler/coreSyn/CoreUnfold.hs-boot view
@@ -0,0 +1,14 @@+module CoreUnfold (+ mkUnfolding+ ) where++import GhcPrelude+import CoreSyn+import DynFlags++mkUnfolding :: DynFlags+ -> UnfoldingSource+ -> Bool+ -> Bool+ -> CoreExpr+ -> Unfolding
compiler/hsSyn/HsBinds.hs view
@@ -28,7 +28,6 @@ import HsExtension import HsTypes-import PprCore () import CoreSyn import TcEvidence import Type
compiler/hsSyn/HsSyn.hs view
@@ -50,7 +50,7 @@ import BasicTypes ( Fixity, WarningTxt ) import HsUtils import HsDoc-import HsInstances ()+import HsInstances () -- For Data instances -- others: import Outputable
compiler/hsSyn/HsTypes.hs view
@@ -77,7 +77,6 @@ import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) import HsExtension-import HsLit () -- for instances import Id ( Id ) import Name( Name )
compiler/hsSyn/HsUtils.hs view
@@ -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
compiler/iface/IfaceSyn.hs view
@@ -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
compiler/main/DynFlags.hs view
@@ -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) {- -----------------------------------------------------------------------------
compiler/main/HeaderInfo.hs view
@@ -35,7 +35,6 @@ import ErrUtils import Util import Outputable-import Pretty () import Maybes import Bag ( emptyBag, listToBag, unitBag ) import MonadUtils
compiler/prelude/PrelRules.hs view
@@ -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
compiler/simplStg/RepType.hs view
@@ -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
compiler/typecheck/TcRnTypes.hs view
@@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/utils/Bag.hs view
@@ -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
compiler/utils/Binary.hs view
@@ -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
− compiler/utils/Fingerprint.hsc
@@ -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
compiler/utils/MonadUtils.hs view
@@ -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))
compiler/utils/UniqDFM.hs view
@@ -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
compiler/utils/UniqFM.hs view
@@ -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
compiler/utils/Util.hs view
@@ -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' {- -- -----------------------------------------------------------------------------
ghc-lib-parser.cabal view
@@ -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
ghc-lib/generated/ghcversion.h view
@@ -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__ || \
ghc-lib/stage0/compiler/build/Parser.hs view
@@ -12744,313 +12744,7 @@ {-# LINE 19 "<built-in>" #-}-{-# 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" #-}
ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs view
@@ -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"
− ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/Constants.hs
@@ -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" #-}
− ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/InfoTable.hs
@@ -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" #-}
− ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/InfoTable/Types.hs
@@ -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--- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/storage/InfoTables.h>--- 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)
− ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/InfoTableProf.hs
@@ -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" #-}
− ghc-lib/stage0/libraries/ghc-heap/build/GHC/Exts/Heap/Utils.hs
@@ -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)
− ghc-lib/stage0/libraries/ghci/build/GHCi/FFI.hs
@@ -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 ()
libraries/ghc-boot/GHC/Platform.hs view
@@ -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
libraries/ghci/GHCi/Message.hs view
@@ -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