never executed always true always false
1 {-|
2 Prepare the STG for bytecode generation:
3
4 - Ensure that all breakpoints are directly under
5 a let-binding, introducing a new binding for
6 those that aren't already.
7
8 - Protect Not-necessarily lifted join points, see
9 Note [Not-necessarily-lifted join points]
10
11 -}
12
13 module GHC.Stg.BcPrep ( bcPrep ) where
14
15 import GHC.Prelude
16
17 import GHC.Types.Id.Make
18 import GHC.Types.Id
19 import GHC.Core.Type
20 import GHC.Builtin.Types ( unboxedUnitTy )
21 import GHC.Builtin.Types.Prim
22 import GHC.Types.Unique
23 import GHC.Data.FastString
24 import GHC.Utils.Panic.Plain
25 import GHC.Types.Tickish
26 import GHC.Types.Unique.Supply
27 import qualified GHC.Types.CostCentre as CC
28 import GHC.Stg.Syntax
29 import GHC.Utils.Monad.State.Strict
30
31 data BcPrepM_State
32 = BcPrepM_State
33 { prepUniqSupply :: !UniqSupply -- for generating fresh variable names
34 }
35
36 type BcPrepM a = State BcPrepM_State a
37
38 bcPrepRHS :: StgRhs -> BcPrepM StgRhs
39 -- explicitly match all constructors so we get a warning if we miss any
40 bcPrepRHS (StgRhsClosure fvs cc upd args (StgTick bp@Breakpoint{} expr)) = do
41 {- If we have a breakpoint directly under an StgRhsClosure we don't
42 need to introduce a new binding for it.
43 -}
44 expr' <- bcPrepExpr expr
45 pure (StgRhsClosure fvs cc upd args (StgTick bp expr'))
46 bcPrepRHS (StgRhsClosure fvs cc upd args expr) =
47 StgRhsClosure fvs cc upd args <$> bcPrepExpr expr
48 bcPrepRHS con@StgRhsCon{} = pure con
49
50 bcPrepExpr :: StgExpr -> BcPrepM StgExpr
51 -- explicitly match all constructors so we get a warning if we miss any
52 bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs)
53 | isLiftedTypeKind (typeKind tick_ty) = do
54 id <- newId tick_ty
55 rhs' <- bcPrepExpr rhs
56 let expr' = StgTick bp rhs'
57 bnd = StgNonRec id (StgRhsClosure noExtFieldSilent
58 CC.dontCareCCS
59 ReEntrant
60 []
61 expr'
62 )
63 letExp = StgLet noExtFieldSilent bnd (StgApp id [])
64 pure letExp
65 | otherwise = do
66 id <- newId (mkVisFunTyMany realWorldStatePrimTy tick_ty)
67 rhs' <- bcPrepExpr rhs
68 let expr' = StgTick bp rhs'
69 bnd = StgNonRec id (StgRhsClosure noExtFieldSilent
70 CC.dontCareCCS
71 ReEntrant
72 [voidArgId]
73 expr'
74 )
75 pure $ StgLet noExtFieldSilent bnd (StgApp id [StgVarArg realWorldPrimId])
76 bcPrepExpr (StgTick tick rhs) =
77 StgTick tick <$> bcPrepExpr rhs
78 bcPrepExpr (StgLet xlet bnds expr) =
79 StgLet xlet <$> bcPrepBind bnds
80 <*> bcPrepExpr expr
81 bcPrepExpr (StgLetNoEscape xlne bnds expr) =
82 StgLet xlne <$> bcPrepBind bnds
83 <*> bcPrepExpr expr
84 bcPrepExpr (StgCase expr bndr alt_type alts) =
85 StgCase <$> bcPrepExpr expr
86 <*> pure bndr
87 <*> pure alt_type
88 <*> mapM bcPrepAlt alts
89 bcPrepExpr lit@StgLit{} = pure lit
90 -- See Note [Not-necessarily-lifted join points], step 3.
91 bcPrepExpr (StgApp x [])
92 | isNNLJoinPoint x = pure $
93 StgApp (protectNNLJoinPointId x) [StgVarArg voidPrimId]
94 bcPrepExpr app@StgApp{} = pure app
95 bcPrepExpr app@StgConApp{} = pure app
96 bcPrepExpr app@StgOpApp{} = pure app
97
98 bcPrepAlt :: StgAlt -> BcPrepM StgAlt
99 bcPrepAlt (ac, bndrs, expr) = (,,) ac bndrs <$> bcPrepExpr expr
100
101 bcPrepBind :: StgBinding -> BcPrepM StgBinding
102 -- explicitly match all constructors so we get a warning if we miss any
103 bcPrepBind (StgNonRec bndr rhs) =
104 let (bndr', rhs') = bcPrepSingleBind (bndr, rhs)
105 in StgNonRec bndr' <$> bcPrepRHS rhs'
106 bcPrepBind (StgRec bnds) =
107 StgRec <$> mapM ((\(b,r) -> (,) b <$> bcPrepRHS r) . bcPrepSingleBind)
108 bnds
109
110 bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs)
111 -- If necessary, modify this Id and body to protect not-necessarily-lifted join points.
112 -- See Note [Not-necessarily-lifted join points], step 2.
113 bcPrepSingleBind (x, StgRhsClosure ext cc upd_flag args body)
114 | isNNLJoinPoint x
115 = ( protectNNLJoinPointId x
116 , StgRhsClosure ext cc upd_flag (args ++ [voidArgId]) body)
117 bcPrepSingleBind bnd = bnd
118
119 bcPrepTopLvl :: StgTopBinding -> BcPrepM StgTopBinding
120 bcPrepTopLvl lit@StgTopStringLit{} = pure lit
121 bcPrepTopLvl (StgTopLifted bnd) = StgTopLifted <$> bcPrepBind bnd
122
123 bcPrep :: UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]
124 bcPrep us bnds = evalState (mapM bcPrepTopLvl bnds) (BcPrepM_State us)
125
126 -- Is this Id a not-necessarily-lifted join point?
127 -- See Note [Not-necessarily-lifted join points], step 1
128 isNNLJoinPoint :: Id -> Bool
129 isNNLJoinPoint x = isJoinId x &&
130 Just True /= isLiftedType_maybe (idType x)
131
132 -- Update an Id's type to take a Void# argument.
133 -- Precondition: the Id is a not-necessarily-lifted join point.
134 -- See Note [Not-necessarily-lifted join points]
135 protectNNLJoinPointId :: Id -> Id
136 protectNNLJoinPointId x
137 = assert (isNNLJoinPoint x )
138 updateIdTypeButNotMult (unboxedUnitTy `mkVisFunTyMany`) x
139
140 newUnique :: BcPrepM Unique
141 newUnique = state $
142 \st -> case takeUniqFromSupply (prepUniqSupply st) of
143 (uniq, us) -> (uniq, st { prepUniqSupply = us })
144
145 newId :: Type -> BcPrepM Id
146 newId ty = do
147 uniq <- newUnique
148 return $ mkSysLocal prepFS uniq Many ty
149
150 prepFS :: FastString
151 prepFS = fsLit "bcprep"
152
153 {-
154
155 Note [Not-necessarily-lifted join points]
156 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
157 A join point variable is essentially a goto-label: it is, for example,
158 never used as an argument to another function, and it is called only
159 in tail position. See Note [Join points] and Note [Invariants on join points],
160 both in GHC.Core. Because join points do not compile to true, red-blooded
161 variables (with, e.g., registers allocated to them), they are allowed
162 to be representation-polymorphic.
163 (See invariant #6 in Note [Invariants on join points] in GHC.Core.)
164
165 However, in this byte-code generator, join points *are* treated just as
166 ordinary variables. There is no check whether a binding is for a join point
167 or not; they are all treated uniformly. (Perhaps there is a missed optimization
168 opportunity here, but that is beyond the scope of my (Richard E's) Thursday.)
169
170 We thus must have *some* strategy for dealing with representation-polymorphic
171 and unlifted join points. Representation-polymorphic variables are generally
172 not allowed (though representation -polymorphic join points *are*; see
173 Note [Invariants on join points] in GHC.Core, point 6), and we don't wish to
174 evaluate unlifted join points eagerly.
175 The questionable join points are *not-necessarily-lifted join points*
176 (NNLJPs). (Not having such a strategy led to #16509, which panicked in the
177 isUnliftedType check in the AnnVar case of schemeE.) Here is the strategy:
178
179 1. Detect NNLJPs. This is done in isNNLJoinPoint.
180
181 2. When binding an NNLJP, add a `\ (_ :: (# #)) ->` to its RHS, and modify the
182 type to tack on a `(# #) ->`.
183 Note that functions are never representation-polymorphic, so this
184 transformation changes an NNLJP to a non-representation-polymorphic
185 join point. This is done in bcPrepSingleBind.
186
187 3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId),
188 being careful to note the new type of the NNLJP. This is done in the AnnVar
189 case of schemeE, with help from protectNNLJoinPointId.
190
191 Here is an example. Suppose we have
192
193 f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).
194 join j :: a
195 j = error @r @a "bloop"
196 in case x of
197 A -> j
198 B -> j
199 C -> error @r @a "blurp"
200
201 Our plan is to behave is if the code was
202
203 f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).
204 let j :: (Void# -> a)
205 j = \ _ -> error @r @a "bloop"
206 in case x of
207 A -> j void#
208 B -> j void#
209 C -> error @r @a "blurp"
210
211 It's a bit hacky, but it works well in practice and is local. I suspect the
212 Right Fix is to take advantage of join points as goto-labels.
213
214 -}
215