Andreas Klebinger pushed to branch wip/andreask/cbv_array at Glasgow Haskell Compiler / GHC Commits: 471d9a01 by Andreas Klebinger at 2025-11-09T17:32:56+01:00 Add strict array read/write primops. Those will enfore argument evaluation using the EPT mechanism for writes. For reads the compiler has knowledge that those are evaluated references allowing us to skip eval checks. - - - - - 17 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Stg/EnforceEpt.hs - compiler/GHC/Stg/EnforceEpt/Rewrite.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Types/Id.hs - compiler/GHC/Types/Id/Info.hs - compiler/Setup.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Rules/Lint.hs - hadrian/src/Settings/Builders/GenPrimopCode.hs - utils/genprimopcode/Lexer.x - utils/genprimopcode/Main.hs - utils/genprimopcode/Parser.y - utils/genprimopcode/ParserM.hs - utils/genprimopcode/Syntax.hs Changes: ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -9,7 +9,7 @@ module GHC.Builtin.PrimOps ( PrimOp(..), PrimOpVecCat(..), allThePrimOps, - primOpType, primOpSig, primOpResultType, + primOpType, primOpSig, primOpResultType, primOpCbv, primOpTag, maxPrimOpTag, primOpOcc, primOpWrapperId, pprPrimOp, @@ -146,6 +146,22 @@ primOpStrictness :: PrimOp -> Arity -> DmdSig -- this function isn't exported. #include "primop-strictness.hs-incl" +{- +************************************************************************ +* * +\subsubsection{Call by value info} +* * +************************************************************************ + +Some primops require us to only pass evaluated and properly tagged +pointers for boxed arguments. + +See Note [Evaluated and Properly Tagged] +-} + +primOpCbv :: PrimOp -> [CbvMark] +#include "primop-cbv.hs-incl" + {- ************************************************************************ * * ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -150,6 +150,7 @@ defaults div_like = False -- Second argument expected to be non zero - used for tests shift_like = False -- Second argument expected to be atmost first argument's word size -1 - used for tests defined_bits = Nothing -- The number of bits the operation is defined for (if not all bits) + cbv_marks = [] -- Note [When do out-of-line primops go in primops.txt.pp] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1621,6 +1622,28 @@ primop ReadArrayOp "readArray#" GenPrimOp effect = ReadWriteEffect can_fail_warning = YesWarnCanFail +primop ReadStrictArrayOp "unsafeReadStrictArray#" GenPrimOp + MutableArray# s a -> Int# -> State# s -> (# State# s, a #) + {Read from specified index of mutable array. Result is evaluated. + + GHC will assume the value at the given index has been written + by writeStrictArray#. This can allow GHC to elid an eval check when using the + read value. Potentially given a performance benefit. + + WARNING: Behaviour is undefined if the value read + was not written using writeStrictArray#. + + At runtime "strict" arrays and regular arrays have the same representation. + The only difference is in the read/write operations. + + The strict write operations ensure stored values are evaluated and properly + tagged. Strict reads assume this fact, allowing GHC to sometimes avoid + checking for thunks when using the read value. + } + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + primop WriteArrayOp "writeArray#" GenPrimOp MutableArray# s a_levpoly -> Int# -> a_levpoly -> State# s -> State# s {Write to specified index of mutable array.} @@ -1629,6 +1652,15 @@ primop WriteArrayOp "writeArray#" GenPrimOp can_fail_warning = YesWarnCanFail code_size = 2 -- card update too +primop WriteStrictArrayOp "writeStrictArray#" GenPrimOp + MutableArray# s a_levpoly -> Int# -> a_levpoly -> State# s -> State# s + {Write to specified index of mutable array. Evaluates the argument before writing it.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = 2 -- card update too + cbv_marks = [!,!,!] + primop SizeofArrayOp "sizeofArray#" GenPrimOp Array# a_levpoly -> Int# {Return the number of elements in the array.} @@ -1637,6 +1669,23 @@ primop SizeofMutableArrayOp "sizeofMutableArray#" GenPrimOp MutableArray# s a_levpoly -> Int# {Return the number of elements in the array.} +primop IndexStrictArrayOp "unsafeIndexStrictArray#" GenPrimOp + Array# a_levpoly -> Int# -> (# a_levpoly #) + {Read from the specified index of an immutable array. The result is packaged + into an unboxed unary tuple; the result itself is evaluated. + Pattern matching on the tuple forces the indexing of the + array to happen. + + GHC will assume the value at the given index has been written + by writeStrictArray#. This can allow GHC to elid an eval check when using the + read value. Potentially given a performance benefit. + + WARNING: Behaviour is undefined if the value read + was not written using writeStrictArray#. + } + with + effect = CanFail + primop IndexArrayOp "indexArray#" GenPrimOp Array# a_levpoly -> Int# -> (# a_levpoly #) {Read from the specified index of an immutable array. The result is packaged @@ -1838,6 +1887,27 @@ primop ReadSmallArrayOp "readSmallArray#" GenPrimOp effect = ReadWriteEffect can_fail_warning = YesWarnCanFail +primop ReadSmallStrictArrayOp "unsafeReadSmallStrictArray#" GenPrimOp + SmallMutableArray# s a -> Int# -> State# s -> (# State# s, a #) + {Read from specified index of mutable array. + + GHC will assume the value at the given index has been evaluted *and tagged* + by writeStrictArray#. This can allow GHC to elid an eval check when using the + read value. Potentially given a performance benefit. + + WARNING: Behaviour is undefined if the value read + was not written using writeStrictArray#. + + At runtime "strict" arrays and regular arrays have the same representation. + The only difference is in the read/write operations. + + The strict write operations ensure stored values are evaluated and properly + tagged. Strict reads assume this fact, allowing GHC to sometimes avoid + checking for thunks when using the read value.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + primop WriteSmallArrayOp "writeSmallArray#" GenPrimOp SmallMutableArray# s a_levpoly -> Int# -> a_levpoly -> State# s -> State# s {Write to specified index of mutable array.} @@ -1845,6 +1915,16 @@ primop WriteSmallArrayOp "writeSmallArray#" GenPrimOp effect = ReadWriteEffect can_fail_warning = YesWarnCanFail +primop WriteSmallStrictArrayOp "writeSmallStrictArray#" GenPrimOp + SmallMutableArray# s a_levpoly -> Int# -> a_levpoly -> State# s -> State# s + {Write to specified index of mutable array. + + Evaluates the argument before storing it.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + cbv_marks = [!,!,!] + primop SizeofSmallArrayOp "sizeofSmallArray#" GenPrimOp SmallArray# a_levpoly -> Int# {Return the number of elements in the array.} @@ -1870,6 +1950,20 @@ primop IndexSmallArrayOp "indexSmallArray#" GenPrimOp with effect = CanFail +primop IndexSmallStrictArrayOp "unsafeIndexSmallStrictArray#" GenPrimOp + SmallArray# a -> Int# -> (# a #) + {Read from specified index of immutable array. Result is packaged into + an unboxed singleton; + + GHC will assume the value at the given index has been written + by writeSmallStrictArray#. This can allow GHC to elid an eval check when using the + read value. Potentially given a performance benefit. + + WARNING: Behaviour is undefined if the value read + was not written using writeSmallStrictArray#} + with + effect = CanFail + primop UnsafeFreezeSmallArrayOp "unsafeFreezeSmallArray#" GenPrimOp SmallMutableArray# s a_levpoly -> State# s -> (# State# s, SmallArray# a_levpoly #) {Make a mutable array immutable, without copying.} ===================================== compiler/GHC/Stg/EnforceEpt.hs ===================================== @@ -9,6 +9,7 @@ module GHC.Stg.EnforceEpt ( enforceEpt ) where import GHC.Prelude hiding (id) +import qualified GHC.Builtin.PrimOps as PrimOps import GHC.Core.DataCon import GHC.Core.Type import GHC.Types.Id @@ -354,6 +355,16 @@ inferTags for_bytecode binds = -- pprTrace "Binds" (pprGenStgTopBindings shortStgPprOpts $ binds) $ snd (mapAccumL inferTagTopBind (initEnv for_bytecode) binds) +inferPrimAppResult :: PrimOps.PrimOp -> TagInfo +inferPrimAppResult op = + case op of + PrimOps.ReadSmallStrictArrayOp -> TagTuple [TagProper] + PrimOps.ReadStrictArrayOp -> TagTuple [TagProper] + PrimOps.IndexSmallStrictArrayOp -> TagTuple [TagProper] + PrimOps.IndexStrictArrayOp -> TagTuple [TagProper] + _ -> TagDunno + + ----------------------- inferTagTopBind :: TagEnv 'CodeGen -> GenStgTopBinding 'CodeGen -> (TagEnv 'CodeGen, GenStgTopBinding 'InferTaggedBinders) @@ -409,11 +420,14 @@ inferTagExpr env (StgTick tick body) where (info, body') = inferTagExpr env body -inferTagExpr _ (StgOpApp op args ty) +inferTagExpr _ (StgOpApp op args ty) = -- Which primops guarantee to return a properly tagged value? -- Probably none, and that is the conservative assumption anyway. -- (And foreign calls definitely need not make promises.) - = (TagDunno, StgOpApp op args ty) + case op of + StgPrimOp prim_op -> (inferPrimAppResult prim_op, StgOpApp op args ty) + StgPrimCallOp {} -> (TagDunno, StgOpApp op args ty) + StgFCallOp {} -> (TagDunno, StgOpApp op args ty) inferTagExpr env (StgLet ext bind body) = (info, StgLet ext bind' body') ===================================== compiler/GHC/Stg/EnforceEpt/Rewrite.hs ===================================== @@ -12,7 +12,7 @@ where import GHC.Prelude -import GHC.Builtin.PrimOps ( PrimOp(..) ) +import GHC.Builtin.PrimOps ( PrimOp(..), primOpCbv ) import GHC.Types.Basic ( CbvMark (..), isMarkedCbv , TopLevelFlag(..), isTopLevel ) import GHC.Types.Id @@ -399,8 +399,7 @@ rewriteExpr (StgTick t e) = StgTick t <$!> rewriteExpr e rewriteExpr e@(StgConApp {}) = rewriteConApp e rewriteExpr e@(StgApp {}) = rewriteApp e rewriteExpr (StgLit lit) = return $! (StgLit lit) -rewriteExpr (StgOpApp op args res_ty) = (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty - +rewriteExpr (StgOpApp op args res_ty) = rewriteOpApp (StgOpApp op args res_ty) rewriteCase :: InferStgExpr -> RM TgStgExpr rewriteCase (StgCase scrut bndr alt_type alts) = @@ -452,6 +451,21 @@ rewriteConApp (StgConApp con cn args tys) = do rewriteConApp _ = panic "Impossible" +{-# INLINE eptArgs #-} +-- Evaluate the relevant arguments, and construct an expression with the ids substituted +-- for their evaluated parts. +eptArgs :: [CbvMark] -> [StgArg] -> ([StgArg] -> TgStgExpr) -> RM TgStgExpr +eptArgs relevant_marks args mkExpr = do + argTags <- mapM isArgTagged args + let argInfo = zipWith3 ((,,)) args (relevant_marks++repeat NotMarkedCbv) argTags :: [(StgArg, CbvMark, Bool)] + + -- untagged cbv arguments + cbvArgs = map fstOf3 . filter (\x -> sndOf3 x == MarkedCbv && thdOf3 x == False) $ argInfo + -- We only need to force ids + cbvArgIds = [x | StgVarArg x <- cbvArgs] :: [Id] + mkSeqs args cbvArgIds mkExpr + + -- Special case: Atomic binders, usually in a case context like `case f of ...`. rewriteApp :: InferStgExpr -> RM TgStgExpr rewriteApp (StgApp f []) = do @@ -464,19 +478,8 @@ rewriteApp (StgApp f args) , relevant_marks <- dropWhileEndLE (not . isMarkedCbv) marks , any isMarkedCbv relevant_marks = assertPpr (length relevant_marks <= length args) (ppr f $$ ppr args $$ ppr relevant_marks) - unliftArg relevant_marks - - where - -- If the function expects any argument to be call-by-value ensure the argument is already - -- evaluated. - unliftArg relevant_marks = do - argTags <- mapM isArgTagged args - let argInfo = zipWith3 ((,,)) args (relevant_marks++repeat NotMarkedCbv) argTags :: [(StgArg, CbvMark, Bool)] - - -- untagged cbv argument positions - cbvArgInfo = filter (\x -> sndOf3 x == MarkedCbv && thdOf3 x == False) argInfo - cbvArgIds = [x | StgVarArg x <- map fstOf3 cbvArgInfo] :: [Id] - mkSeqs args cbvArgIds (\cbv_args -> StgApp f cbv_args) + -- Enforce relevant args are evaluated and tagged. + eptArgs relevant_marks args (\cbv_args -> StgApp f cbv_args) rewriteApp (StgApp f args) = return $ StgApp f args rewriteApp _ = panic "Impossible" @@ -500,10 +503,14 @@ So for these we should call `rewriteArgs`. rewriteOpApp :: InferStgExpr -> RM TgStgExpr rewriteOpApp (StgOpApp op args res_ty) = case op of + -- Should we just use cbv marks for DataToTag? op@(StgPrimOp primOp) | primOp == DataToTagSmallOp || primOp == DataToTagLargeOp -- see Note [Rewriting primop arguments] -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty + | marks <- primOpCbv primOp + , not (null marks) + -> eptArgs marks args (\tagged_args -> (StgOpApp op tagged_args res_ty)) _ -> pure $! StgOpApp op args res_ty rewriteOpApp _ = panic "Impossible" ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -380,17 +380,29 @@ emitPrimOp cfg primop = ReadArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadPtrArrayOp res obj ix + ReadStrictArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> + doReadPtrArrayOp res obj ix IndexArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadPtrArrayOp res obj ix + IndexStrictArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> + doReadPtrArrayOp res obj ix WriteArrayOp -> \[obj, ix, v] -> opIntoRegs $ \[] -> doWritePtrArrayOp obj ix v + WriteStrictArrayOp -> \[obj, ix, v] -> opIntoRegs $ \[] -> + doWritePtrArrayOp obj ix v ReadSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadSmallPtrArrayOp res obj ix + ReadSmallStrictArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> + doReadSmallPtrArrayOp res obj ix IndexSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadSmallPtrArrayOp res obj ix + IndexSmallStrictArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> + doReadSmallPtrArrayOp res obj ix WriteSmallArrayOp -> \[obj,ix,v] -> opIntoRegs $ \[] -> doWriteSmallPtrArrayOp obj ix v + WriteSmallStrictArrayOp -> \[obj,ix,v] -> opIntoRegs $ \[] -> + doWriteSmallPtrArrayOp obj ix v -- Getting the size of pointer arrays ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -559,7 +559,9 @@ genPrim prof bound ty op = case op of NewArrayOp -> \[r] [l,e] -> pure $ PrimInline $ r |= app hdNewArrayStr [l,e] ReadArrayOp -> \[r] [a,i] -> pure $ PrimInline $ bnd_arr bound a i (r |= a .! i) + ReadStrictArrayOp -> \[r] [a,i] -> pure $ PrimInline $ bnd_arr bound a i (r |= a .! i) WriteArrayOp -> \[] [a,i,v] -> pure $ PrimInline $ bnd_arr bound a i (a .! i |= v) + WriteStrictArrayOp -> \[] [a,i,v] -> pure $ PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> pure $ PrimInline $ r |= a .^ lngth SizeofMutableArrayOp -> \[r] [a] -> pure $ PrimInline $ r |= a .^ lngth IndexArrayOp -> \[r] [a,i] -> pure $ PrimInline $ bnd_arr bound a i (r |= a .! i) @@ -623,7 +625,9 @@ genPrim prof bound ty op = case op of NewSmallArrayOp -> \[a] [n,e] -> pure $ PrimInline $ a |= app hdNewArrayStr [n,e] ReadSmallArrayOp -> \[r] [a,i] -> pure $ PrimInline $ bnd_arr bound a i (r |= a .! i) + ReadSmallStrictArrayOp -> \[r] [a,i] -> pure $ PrimInline $ bnd_arr bound a i (r |= a .! i) WriteSmallArrayOp -> \[] [a,i,e] -> pure $ PrimInline $ bnd_arr bound a i (a .! i |= e) + WriteSmallStrictArrayOp -> \[] [a,i,e] -> pure $ PrimInline $ bnd_arr bound a i (a .! i |= e) -- todo check-tags? SizeofSmallArrayOp -> \[r] [a] -> pure $ PrimInline $ r |= a .^ lngth SizeofSmallMutableArrayOp -> \[r] [a] -> pure $ PrimInline $ r |= a .^ lngth IndexSmallArrayOp -> \[r] [a,i] -> pure $ PrimInline $ bnd_arr bound a i (r |= a .! i) ===================================== compiler/GHC/Types/Id.hs ===================================== @@ -513,8 +513,8 @@ isDFunId id = case Var.idDetails id of _ -> False isPrimOpId_maybe id = case Var.idDetails id of - PrimOpId op _ -> Just op - _ -> Nothing + PrimOpId op _ -> Just op + _ -> Nothing isFCallId id = case Var.idDetails id of FCallId _ -> True @@ -845,7 +845,7 @@ setIdCbvMarks id marks idCbvMarks_maybe :: Id -> Maybe [CbvMark] idCbvMarks_maybe id = case idDetails id of - WorkerLikeId marks -> Just marks + WorkerLikeId marks -> Just marks JoinId _arity marks -> marks _ -> Nothing ===================================== compiler/GHC/Types/Id/Info.hs ===================================== @@ -395,7 +395,7 @@ pprIdDetails VanillaId = empty pprIdDetails other = brackets (pp other) where pp VanillaId = panic "pprIdDetails" - pp (WorkerLikeId dmds) = text "StrictWorker" <> parens (ppr dmds) + pp (WorkerLikeId dmds) = text "StrictWorker" <> pp_marks dmds pp (DataConWorkId _) = text "DataCon" pp (DataConWrapId _) = text "DataConWrapper" pp (ClassOpId {}) = text "ClassOp" @@ -410,6 +410,9 @@ pprIdDetails other = brackets (pp other) pp CoVarId = text "CoVarId" pp (JoinId arity marks) = text "JoinId" <> parens (int arity) <> parens (ppr marks) + pp_marks [] = empty + pp_marks xs = ppr xs + {- ************************************************************************ * * ===================================== compiler/Setup.hs ===================================== @@ -47,6 +47,7 @@ primopIncls = , ("primop-commutable.hs-incl" , "--commutable") , ("primop-code-size.hs-incl" , "--code-size") , ("primop-strictness.hs-incl" , "--strictness") + , ("primop-cbv.hs-incl" , "--cbv") , ("primop-is-work-free.hs-incl" , "--is-work-free") , ("primop-is-cheap.hs-incl" , "--is-cheap") , ("primop-fixity.hs-incl" , "--fixity") ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -92,6 +92,7 @@ compilerDependencies = do , "primop-out-of-line.hs-incl" , "primop-primop-info.hs-incl" , "primop-strictness.hs-incl" + , "primop-cbv.hs-incl" , "primop-is-work-free.hs-incl" , "primop-is-cheap.hs-incl" , "primop-tag.hs-incl" ===================================== hadrian/src/Rules/Lint.hs ===================================== @@ -111,6 +111,7 @@ hsIncls path = [ path "primop-vector-tycons.hs-incl" , path "primop-tag.hs-incl" , path "primop-list.hs-incl" , path "primop-strictness.hs-incl" + , path "primop-cbv.hs-incl" , path "primop-is-work-free.hs-incl" , path "primop-is-cheap.hs-incl" , path "primop-fixity.hs-incl" ===================================== hadrian/src/Settings/Builders/GenPrimopCode.hs ===================================== @@ -14,6 +14,7 @@ genPrimopCodeBuilderArgs = builder GenPrimopCode ? mconcat , output "//primop-commutable.hs-incl" ? arg "--commutable" , output "//primop-code-size.hs-incl" ? arg "--code-size" , output "//primop-strictness.hs-incl" ? arg "--strictness" + , output "//primop-cbv.hs-incl" ? arg "--cbv" , output "//primop-is-work-free.hs-incl" ? arg "--is-work-free" , output "//primop-is-cheap.hs-incl" ? arg "--is-cheap" , output "//primop-fixity.hs-incl" ? arg "--fixity" ===================================== utils/genprimopcode/Lexer.x ===================================== @@ -36,6 +36,8 @@ words :- <0> "]" { mkT TCloseBracket } <0> "<" { mkT TOpenAngle } <0> ">" { mkT TCloseAngle } + <0> "!" { mkT TBang } + <0> "~" { mkT TTilde } <0> "section" { mkT TSection } <0> "primop" { mkT TPrimop } <0> "pseudoop" { mkT TPseudoop } @@ -62,6 +64,7 @@ words :- <0> "WarnIfEffectIsCanFail" { mkT TWarnIfEffectIsCanFail } <0> "YesWarnCanFail" { mkT TYesWarnCanFail } <0> "vector" { mkT TVector } + <0> "cbv_marks" { mkT TCbv_marks } <0> "bytearray_access_ops" { mkT TByteArrayAccessOps } <0> "addr_access_ops" { mkT TAddrAccessOps } <0> "thats_all_folks" { mkT TThatsAllFolks } ===================================== utils/genprimopcode/Main.hs ===================================== @@ -170,6 +170,11 @@ main = getArgs >>= \args -> "strictness" "primOpStrictness" p_o_specs) + "--cbv" + -> putStr (gen_switch_from_attribs + "cbv_marks" + "primOpCbv" p_o_specs) + "--fixity" -> putStr (gen_switch_from_attribs "fixity" @@ -228,6 +233,7 @@ known_args "--is-work-free", "--is-cheap", "--strictness", + "--cbv", "--fixity", "--primop-effects", "--primop-primop-info", @@ -318,6 +324,7 @@ gen_hs_source (Info defaults entries) = opt (OptionInteger n v) = n ++ " = " ++ show v opt (OptionVector _) = "" opt (OptionFixity mf) = "fixity = " ++ show mf + opt (OptionCbvMarks marks) = "cbv_marks = " ++ show marks opt (OptionEffect eff) = "effect = " ++ show eff opt (OptionDefinedBits bc) = "defined_bits = " ++ show bc opt (OptionCanFailWarnFlag wf) = "can_fail_warning = " ++ show wf @@ -645,6 +652,11 @@ gen_switch_from_attribs attrib_name fn_name (Info defaults entries) getAltRhs (OptionString _ s) = s getAltRhs (OptionVector _) = "True" getAltRhs (OptionFixity mf) = show mf + getAltRhs (OptionCbvMarks marks) = + "[" ++ concat (intersperse "," (map showMark marks)) ++ "]" + where + showMark True = "MarkedCbv" + showMark False = "NotMarkedCbv" getAltRhs (OptionEffect eff) = show eff getAltRhs (OptionDefinedBits bc) = show bc getAltRhs (OptionCanFailWarnFlag wf) = show wf ===================================== utils/genprimopcode/Parser.y ===================================== @@ -30,6 +30,8 @@ import AccessOps ']' { TCloseBracket } '<' { TOpenAngle } '>' { TCloseAngle } + '!' { TBang } + '~' { TTilde } section { TSection } primop { TPrimop } pseudoop { TPseudoop } @@ -56,6 +58,7 @@ import AccessOps WarnIfEffectIsCanFail { TWarnIfEffectIsCanFail } YesWarnCanFail { TYesWarnCanFail } vector { TVector } + cbv_marks { TCbv_marks } SCALAR { TSCALAR } VECTOR { TVECTOR } VECTUPLE { TVECTUPLE } @@ -87,6 +90,7 @@ pOption : lowerName '=' false { OptionFalse $1 } | lowerName '=' pStuffBetweenBraces { OptionString $1 $3 } | lowerName '=' integer { OptionInteger $1 $3 } | vector '=' pVectorTemplate { OptionVector $3 } + | cbv_marks '=' pCbvMarks { OptionCbvMarks $3 } | fixity '=' pInfix { OptionFixity $3 } | effect '=' pEffect { OptionEffect $3 } | defined_bits '=' pGoodBits { OptionDefinedBits $3 } @@ -175,6 +179,18 @@ pInside :: { String } pInside : '{' pInsides '}' { "{" ++ $2 ++ "}" } | noBraces { $1 } +pCbvMarks :: { [Bool] } +pCbvMarks : '[' pMarks ']' { $2 } + +pMarks :: { [Bool] } +pMarks : pMark ',' pMarks { [$1] ++ $3 } + | pMark { [$1] } + | {- empty -} { [] } + +pMark :: { Bool } +pMark : '!' { True } + | '~' { False } + pVectorTemplate :: { [(String, String, Int)] } pVectorTemplate : '[' pVectors ']' { $2 } ===================================== utils/genprimopcode/ParserM.hs ===================================== @@ -75,6 +75,8 @@ init_state = St { data Token = TEOF | TArrow + | TBang + | TTilde | TDArrow | TEquals | TComma @@ -122,6 +124,7 @@ data Token = TEOF | TWarnIfEffectIsCanFail | TYesWarnCanFail | TVector + | TCbv_marks | TSCALAR | TVECTOR | TVECTUPLE ===================================== utils/genprimopcode/Syntax.hs ===================================== @@ -83,6 +83,7 @@ data Option | OptionEffect PrimOpEffect -- effect = NoEffect | DoNotSpeculate | CanFail | ThrowsException | ReadWriteEffect | FallibleReadWriteEffect | OptionCanFailWarnFlag PrimOpCanFailWarnFlag -- can_fail_warning = DoNotWarnCanFail | WarnIfEffectIsCanFail | YesWarnCanFail | OptionDefinedBits (Maybe Word) -- defined_bits = Just 16 | Nothing + | OptionCbvMarks [Bool] -- defined_bits = Just 16 | Nothing deriving Show -- categorises primops @@ -200,6 +201,7 @@ get_attrib_name (OptionTrue nm) = nm get_attrib_name (OptionString nm _) = nm get_attrib_name (OptionInteger nm _) = nm get_attrib_name (OptionVector _) = "vector" +get_attrib_name (OptionCbvMarks _) = "cbv_marks" get_attrib_name (OptionFixity _) = "fixity" get_attrib_name (OptionEffect _) = "effect" get_attrib_name (OptionCanFailWarnFlag _) = "can_fail_warning" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/471d9a01934c6b40fcb2ffa6b3df5b1c... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/471d9a01934c6b40fcb2ffa6b3df5b1c... You're receiving this email because of your account on gitlab.haskell.org.