never executed always true always false
1
2 {-# LANGUAGE DeriveFunctor #-}
3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
4 {-# LANGUAGE RecordWildCards #-}
5
6 {-# OPTIONS_GHC -fprof-auto-top #-}
7 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
8
9 --
10 -- (c) The University of Glasgow 2002-2006
11 --
12
13 -- | GHC.StgToByteCode: Generate bytecode from STG
14 module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen) where
15
16 import GHC.Prelude
17
18 import GHC.Driver.Session
19 import GHC.Driver.Env
20
21 import GHC.ByteCode.Instr
22 import GHC.ByteCode.Asm
23 import GHC.ByteCode.Types
24
25 import GHC.Cmm.CallConv
26 import GHC.Cmm.Expr
27 import GHC.Cmm.Node
28 import GHC.Cmm.Utils
29
30 import GHC.Platform
31 import GHC.Platform.Profile
32
33 import GHC.Runtime.Interpreter
34 import GHCi.FFI
35 import GHCi.RemoteTypes
36 import GHC.Types.Basic
37 import GHC.Utils.Outputable
38 import GHC.Types.Name
39 import GHC.Types.Id
40 import GHC.Types.ForeignCall
41 import GHC.Core
42 import GHC.Types.Literal
43 import GHC.Builtin.PrimOps
44 import GHC.Core.Type
45 import GHC.Types.RepType
46 import GHC.Core.DataCon
47 import GHC.Core.TyCon
48 import GHC.Utils.Misc
49 import GHC.Utils.Logger
50 import GHC.Types.Var.Set
51 import GHC.Builtin.Types.Prim
52 import GHC.Core.TyCo.Ppr ( pprType )
53 import GHC.Utils.Error
54 import GHC.Types.Unique
55 import GHC.Builtin.Uniques
56 import GHC.Builtin.Utils ( primOpId )
57 import GHC.Data.FastString
58 import GHC.Utils.Panic
59 import GHC.Utils.Panic.Plain
60 import GHC.Utils.Exception (evaluate)
61 import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds )
62 import GHC.StgToCmm.Layout
63 import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
64 import GHC.Data.Bitmap
65 import GHC.Data.OrdList
66 import GHC.Data.Maybe
67 import GHC.Types.Var.Env
68 import GHC.Types.Tickish
69
70 import Data.List ( genericReplicate, genericLength, intersperse
71 , partition, scanl', sort, sortBy, zip4, zip6, nub )
72 import Foreign hiding (shiftL, shiftR)
73 import Control.Monad
74 import Data.Char
75
76 import GHC.Unit.Module
77
78 import Data.Array
79 import Data.Coerce (coerce)
80 import Data.ByteString (ByteString)
81 import Data.Map (Map)
82 import Data.IntMap (IntMap)
83 import qualified Data.Map as Map
84 import qualified Data.IntMap as IntMap
85 import qualified GHC.Data.FiniteMap as Map
86 import Data.Ord
87 import GHC.Stack.CCS
88 import Data.Either ( partitionEithers )
89
90 import GHC.Stg.Syntax
91 import GHC.Stg.FVs
92
93 -- -----------------------------------------------------------------------------
94 -- Generating byte code for a complete module
95
96 byteCodeGen :: HscEnv
97 -> Module
98 -> [StgTopBinding]
99 -> [TyCon]
100 -> Maybe ModBreaks
101 -> IO CompiledByteCode
102 byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
103 = withTiming logger
104 (text "GHC.StgToByteCode"<+>brackets (ppr this_mod))
105 (const ()) $ do
106 -- Split top-level binds into strings and others.
107 -- See Note [generating code for top-level string literal bindings].
108 let (strings, lifted_binds) = partitionEithers $ do -- list monad
109 bnd <- binds
110 case bnd of
111 StgTopLifted bnd -> [Right bnd]
112 StgTopStringLit b str -> [Left (b, str)]
113 flattenBind (StgNonRec b e) = [(b,e)]
114 flattenBind (StgRec bs) = bs
115 stringPtrs <- allocateTopStrings interp strings
116
117 (BcM_State{..}, proto_bcos) <-
118 runBc hsc_env this_mod mb_modBreaks (mkVarEnv stringPtrs) $ do
119 let flattened_binds =
120 concatMap (flattenBind . annBindingFreeVars) (reverse lifted_binds)
121 mapM schemeTopBind flattened_binds
122
123 when (notNull ffis)
124 (panic "GHC.StgToByteCode.byteCodeGen: missing final emitBc?")
125
126 putDumpFileMaybe logger Opt_D_dump_BCOs
127 "Proto-BCOs" FormatByteCode
128 (vcat (intersperse (char ' ') (map ppr proto_bcos)))
129
130 cbc <- assembleBCOs interp profile proto_bcos tycs (map snd stringPtrs)
131 (case modBreaks of
132 Nothing -> Nothing
133 Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })
134
135 -- Squash space leaks in the CompiledByteCode. This is really
136 -- important, because when loading a set of modules into GHCi
137 -- we don't touch the CompiledByteCode until the end when we
138 -- do linking. Forcing out the thunks here reduces space
139 -- usage by more than 50% when loading a large number of
140 -- modules.
141 evaluate (seqCompiledByteCode cbc)
142
143 return cbc
144
145 where dflags = hsc_dflags hsc_env
146 logger = hsc_logger hsc_env
147 interp = hscInterp hsc_env
148 profile = targetProfile dflags
149
150 allocateTopStrings
151 :: Interp
152 -> [(Id, ByteString)]
153 -> IO [(Var, RemotePtr ())]
154 allocateTopStrings interp topStrings = do
155 let !(bndrs, strings) = unzip topStrings
156 ptrs <- interpCmd interp $ MallocStrings strings
157 return $ zip bndrs ptrs
158
159 {-
160 Note [generating code for top-level string literal bindings]
161
162 Here is a summary on how the byte code generator deals with top-level string
163 literals:
164
165 1. Top-level string literal bindings are separated from the rest of the module.
166
167 2. The strings are allocated via interpCmd, in allocateTopStrings
168
169 3. The mapping from binders to allocated strings (topStrings) are maintained in
170 BcM and used when generating code for variable references.
171 -}
172
173 -- -----------------------------------------------------------------------------
174 -- Compilation schema for the bytecode generator
175
176 type BCInstrList = OrdList BCInstr
177
178 wordsToBytes :: Platform -> WordOff -> ByteOff
179 wordsToBytes platform = fromIntegral . (* platformWordSizeInBytes platform) . fromIntegral
180
181 -- Used when we know we have a whole number of words
182 bytesToWords :: Platform -> ByteOff -> WordOff
183 bytesToWords platform (ByteOff bytes) =
184 let (q, r) = bytes `quotRem` (platformWordSizeInBytes platform)
185 in if r == 0
186 then fromIntegral q
187 else pprPanic "GHC.StgToByteCode.bytesToWords"
188 (text "bytes=" <> ppr bytes)
189
190 wordSize :: Platform -> ByteOff
191 wordSize platform = ByteOff (platformWordSizeInBytes platform)
192
193 type Sequel = ByteOff -- back off to this depth before ENTER
194
195 type StackDepth = ByteOff
196
197 -- | Maps Ids to their stack depth. This allows us to avoid having to mess with
198 -- it after each push/pop.
199 type BCEnv = Map Id StackDepth -- To find vars on the stack
200
201 {-
202 ppBCEnv :: BCEnv -> SDoc
203 ppBCEnv p
204 = text "begin-env"
205 $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p))))
206 $$ text "end-env"
207 where
208 pp_one (var, ByteOff offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgReps var)
209 cmp_snd x y = compare (snd x) (snd y)
210 -}
211
212 -- Create a BCO and do a spot of peephole optimisation on the insns
213 -- at the same time.
214 mkProtoBCO
215 :: Platform
216 -> name
217 -> BCInstrList
218 -> Either [CgStgAlt] (CgStgRhs)
219 -- ^ original expression; for debugging only
220 -> Int
221 -> Word16
222 -> [StgWord]
223 -> Bool -- True <=> is a return point, rather than a function
224 -> [FFIInfo]
225 -> ProtoBCO name
226 mkProtoBCO platform nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis
227 = ProtoBCO {
228 protoBCOName = nm,
229 protoBCOInstrs = maybe_with_stack_check,
230 protoBCOBitmap = bitmap,
231 protoBCOBitmapSize = bitmap_size,
232 protoBCOArity = arity,
233 protoBCOExpr = origin,
234 protoBCOFFIs = ffis
235 }
236 where
237 -- Overestimate the stack usage (in words) of this BCO,
238 -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit
239 -- stack check. (The interpreter always does a stack check
240 -- for iNTERP_STACK_CHECK_THRESH words at the start of each
241 -- BCO anyway, so we only need to add an explicit one in the
242 -- (hopefully rare) cases when the (overestimated) stack use
243 -- exceeds iNTERP_STACK_CHECK_THRESH.
244 maybe_with_stack_check
245 | is_ret && stack_usage < fromIntegral (pc_AP_STACK_SPLIM (platformConstants platform)) = peep_d
246 -- don't do stack checks at return points,
247 -- everything is aggregated up to the top BCO
248 -- (which must be a function).
249 -- That is, unless the stack usage is >= AP_STACK_SPLIM,
250 -- see bug #1466.
251 | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH
252 = STKCHECK stack_usage : peep_d
253 | otherwise
254 = peep_d -- the supposedly common case
255
256 -- We assume that this sum doesn't wrap
257 stack_usage = sum (map bciStackUse peep_d)
258
259 -- Merge local pushes
260 peep_d = peep (fromOL instrs_ordlist)
261
262 peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
263 = PUSH_LLL off1 (off2-1) (off3-2) : peep rest
264 peep (PUSH_L off1 : PUSH_L off2 : rest)
265 = PUSH_LL off1 (off2-1) : peep rest
266 peep (i:rest)
267 = i : peep rest
268 peep []
269 = []
270
271 argBits :: Platform -> [ArgRep] -> [Bool]
272 argBits _ [] = []
273 argBits platform (rep : args)
274 | isFollowableArg rep = False : argBits platform args
275 | otherwise = take (argRepSizeW platform rep) (repeat True) ++ argBits platform args
276
277 non_void :: [ArgRep] -> [ArgRep]
278 non_void = filter nv
279 where nv V = False
280 nv _ = True
281
282 -- -----------------------------------------------------------------------------
283 -- schemeTopBind
284
285 -- Compile code for the right-hand side of a top-level binding
286
287 schemeTopBind :: (Id, CgStgRhs) -> BcM (ProtoBCO Name)
288 schemeTopBind (id, rhs)
289 | Just data_con <- isDataConWorkId_maybe id,
290 isNullaryRepDataCon data_con = do
291 platform <- profilePlatform <$> getProfile
292 -- Special case for the worker of a nullary data con.
293 -- It'll look like this: Nil = /\a -> Nil a
294 -- If we feed it into schemeR, we'll get
295 -- Nil = Nil
296 -- because mkConAppCode treats nullary constructor applications
297 -- by just re-using the single top-level definition. So
298 -- for the worker itself, we must allocate it directly.
299 -- ioToBc (putStrLn $ "top level BCO")
300 let enter = if isUnliftedTypeKind (tyConResKind (dataConTyCon data_con))
301 then RETURN_UNLIFTED P
302 else ENTER
303 emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, enter])
304 (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
305
306 | otherwise
307 = schemeR [{- No free variables -}] (getName id, rhs)
308
309
310 -- -----------------------------------------------------------------------------
311 -- schemeR
312
313 -- Compile code for a right-hand side, to give a BCO that,
314 -- when executed with the free variables and arguments on top of the stack,
315 -- will return with a pointer to the result on top of the stack, after
316 -- removing the free variables and arguments.
317 --
318 -- Park the resulting BCO in the monad. Also requires the
319 -- name of the variable to which this value was bound,
320 -- so as to give the resulting BCO a name.
321 schemeR :: [Id] -- Free vars of the RHS, ordered as they
322 -- will appear in the thunk. Empty for
323 -- top-level things, which have no free vars.
324 -> (Name, CgStgRhs)
325 -> BcM (ProtoBCO Name)
326 schemeR fvs (nm, rhs)
327 = schemeR_wrk fvs nm rhs (collect rhs)
328
329 -- If an expression is a lambda, return the
330 -- list of arguments to the lambda (in R-to-L order) and the
331 -- underlying expression
332
333 collect :: CgStgRhs -> ([Var], CgStgExpr)
334 collect (StgRhsClosure _ _ _ args body) = (args, body)
335 collect (StgRhsCon _cc dc cnum _ticks args) = ([], StgConApp dc cnum args [])
336
337 schemeR_wrk
338 :: [Id]
339 -> Name
340 -> CgStgRhs -- expression e, for debugging only
341 -> ([Var], CgStgExpr) -- result of collect on e
342 -> BcM (ProtoBCO Name)
343 schemeR_wrk fvs nm original_body (args, body)
344 = do
345 profile <- getProfile
346 let
347 platform = profilePlatform profile
348 all_args = reverse args ++ fvs
349 arity = length all_args
350 -- all_args are the args in reverse order. We're compiling a function
351 -- \fv1..fvn x1..xn -> e
352 -- i.e. the fvs come first
353
354 -- Stack arguments always take a whole number of words, we never pack
355 -- them unlike constructor fields.
356 szsb_args = map (wordsToBytes platform . idSizeW platform) all_args
357 sum_szsb_args = sum szsb_args
358 p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args))
359
360 -- make the arg bitmap
361 bits = argBits platform (reverse (map (bcIdArgRep platform) all_args))
362 bitmap_size = genericLength bits
363 bitmap = mkBitmap platform bits
364 body_code <- schemeER_wrk sum_szsb_args p_init body
365
366 emitBc (mkProtoBCO platform nm body_code (Right original_body)
367 arity bitmap_size bitmap False{-not alts-})
368
369 -- introduce break instructions for ticked expressions
370 schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList
371 schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs) rhs)
372 = do code <- schemeE d 0 p rhs
373 cc_arr <- getCCArray
374 this_mod <- moduleName <$> getCurrentModule
375 platform <- profilePlatform <$> getProfile
376 let idOffSets = getVarOffSets platform d p fvs
377 let breakInfo = CgBreakInfo
378 { cgb_vars = idOffSets
379 , cgb_resty = tick_ty
380 }
381 newBreakInfo tick_no breakInfo
382 hsc_env <- getHscEnv
383 let cc | Just interp <- hsc_interp hsc_env
384 , interpreterProfiled interp
385 = cc_arr ! tick_no
386 | otherwise = toRemotePtr nullPtr
387 let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc
388 return $ breakInstr `consOL` code
389 schemeER_wrk d p rhs = schemeE d 0 p rhs
390
391 getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)]
392 getVarOffSets platform depth env = map getOffSet
393 where
394 getOffSet id = case lookupBCEnv_maybe id env of
395 Nothing -> Nothing
396 Just offset ->
397 -- michalt: I'm not entirely sure why we need the stack
398 -- adjustment by 2 here. I initially thought that there's
399 -- something off with getIdValFromApStack (the only user of this
400 -- value), but it looks ok to me. My current hypothesis is that
401 -- this "adjustment" is needed due to stack manipulation for
402 -- BRK_FUN in Interpreter.c In any case, this is used only when
403 -- we trigger a breakpoint.
404 let !var_depth_ws =
405 trunc16W $ bytesToWords platform (depth - offset) + 2
406 in Just (id, var_depth_ws)
407
408 truncIntegral16 :: Integral a => a -> Word16
409 truncIntegral16 w
410 | w > fromIntegral (maxBound :: Word16)
411 = panic "stack depth overflow"
412 | otherwise
413 = fromIntegral w
414
415 trunc16B :: ByteOff -> Word16
416 trunc16B = truncIntegral16
417
418 trunc16W :: WordOff -> Word16
419 trunc16W = truncIntegral16
420
421 fvsToEnv :: BCEnv -> CgStgRhs -> [Id]
422 -- Takes the free variables of a right-hand side, and
423 -- delivers an ordered list of the local variables that will
424 -- be captured in the thunk for the RHS
425 -- The BCEnv argument tells which variables are in the local
426 -- environment: these are the ones that should be captured
427 --
428 -- The code that constructs the thunk, and the code that executes
429 -- it, have to agree about this layout
430
431 fvsToEnv p rhs = [v | v <- dVarSetElems $ freeVarsOfRhs rhs,
432 v `Map.member` p]
433
434 -- -----------------------------------------------------------------------------
435 -- schemeE
436
437 -- Returning an unlifted value.
438 -- Heave it on the stack, SLIDE, and RETURN.
439 returnUnliftedAtom
440 :: StackDepth
441 -> Sequel
442 -> BCEnv
443 -> StgArg
444 -> BcM BCInstrList
445 returnUnliftedAtom d s p e = do
446 let reps = case e of
447 StgLitArg lit -> typePrimRepArgs (literalType lit)
448 StgVarArg i -> bcIdPrimReps i
449 (push, szb) <- pushAtom d p e
450 ret <- returnUnliftedReps d s szb reps
451 return (push `appOL` ret)
452
453 -- return an unlifted value from the top of the stack
454 returnUnliftedReps
455 :: StackDepth
456 -> Sequel
457 -> ByteOff -- size of the thing we're returning
458 -> [PrimRep] -- representations
459 -> BcM BCInstrList
460 returnUnliftedReps d s szb reps = do
461 profile <- getProfile
462 let platform = profilePlatform profile
463 non_void VoidRep = False
464 non_void _ = True
465 ret <- case filter non_void reps of
466 -- use RETURN_UBX for unary representations
467 [] -> return (unitOL $ RETURN_UNLIFTED V)
468 [rep] -> return (unitOL $ RETURN_UNLIFTED (toArgRep platform rep))
469 -- otherwise use RETURN_TUPLE with a tuple descriptor
470 nv_reps -> do
471 let (tuple_info, args_offsets) = layoutTuple profile 0 (primRepCmmType platform) nv_reps
472 args_ptrs = map (\(rep, off) -> (isFollowableArg (toArgRep platform rep), off)) args_offsets
473 tuple_bco <- emitBc (tupleBCO platform tuple_info args_ptrs)
474 return $ PUSH_UBX (mkTupleInfoLit platform tuple_info) 1 `consOL`
475 PUSH_BCO tuple_bco `consOL`
476 unitOL RETURN_TUPLE
477 return ( mkSlideB platform szb (d - s) -- clear to sequel
478 `appOL` ret) -- go
479
480 -- construct and return an unboxed tuple
481 returnUnboxedTuple
482 :: StackDepth
483 -> Sequel
484 -> BCEnv
485 -> [StgArg]
486 -> BcM BCInstrList
487 returnUnboxedTuple d s p es = do
488 profile <- getProfile
489 let platform = profilePlatform profile
490 arg_ty e = primRepCmmType platform (atomPrimRep e)
491 (tuple_info, tuple_components) = layoutTuple profile d arg_ty es
492 go _ pushes [] = return (reverse pushes)
493 go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a
494 massert (off == dd + szb)
495 go (dd + szb) (push:pushes) cs
496 pushes <- go d [] tuple_components
497 ret <- returnUnliftedReps d
498 s
499 (wordsToBytes platform $ tupleSize tuple_info)
500 (map atomPrimRep es)
501 return (mconcat pushes `appOL` ret)
502
503 -- Compile code to apply the given expression to the remaining args
504 -- on the stack, returning a HNF.
505 schemeE
506 :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList
507 schemeE d s p (StgLit lit) = returnUnliftedAtom d s p (StgLitArg lit)
508 schemeE d s p (StgApp x [])
509 | isUnliftedType (idType x) = returnUnliftedAtom d s p (StgVarArg x)
510 -- Delegate tail-calls to schemeT.
511 schemeE d s p e@(StgApp {}) = schemeT d s p e
512 schemeE d s p e@(StgConApp {}) = schemeT d s p e
513 schemeE d s p e@(StgOpApp {}) = schemeT d s p e
514 schemeE d s p (StgLetNoEscape xlet bnd body)
515 = schemeE d s p (StgLet xlet bnd body)
516 schemeE d s p (StgLet _xlet
517 (StgNonRec x (StgRhsCon _cc data_con _cnum _ticks args))
518 body)
519 = do -- Special case for a non-recursive let whose RHS is a
520 -- saturated constructor application.
521 -- Just allocate the constructor and carry on
522 alloc_code <- mkConAppCode d s p data_con args
523 platform <- targetPlatform <$> getDynFlags
524 let !d2 = d + wordSize platform
525 body_code <- schemeE d2 s (Map.insert x d2 p) body
526 return (alloc_code `appOL` body_code)
527 -- General case for let. Generates correct, if inefficient, code in
528 -- all situations.
529 schemeE d s p (StgLet _ext binds body) = do
530 platform <- targetPlatform <$> getDynFlags
531 let (xs,rhss) = case binds of StgNonRec x rhs -> ([x],[rhs])
532 StgRec xs_n_rhss -> unzip xs_n_rhss
533 n_binds = genericLength xs
534
535 fvss = map (fvsToEnv p') rhss
536
537 -- Sizes of free vars
538 size_w = trunc16W . idSizeW platform
539 sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss
540
541 -- the arity of each rhs
542 arities = map (genericLength . fst . collect) rhss
543
544 -- This p', d' defn is safe because all the items being pushed
545 -- are ptrs, so all have size 1 word. d' and p' reflect the stack
546 -- after the closures have been allocated in the heap (but not
547 -- filled in), and pointers to them parked on the stack.
548 offsets = mkStackOffsets d (genericReplicate n_binds (wordSize platform))
549 p' = Map.insertList (zipE xs offsets) p
550 d' = d + wordsToBytes platform n_binds
551 zipE = zipEqual "schemeE"
552
553 -- ToDo: don't build thunks for things with no free variables
554 build_thunk
555 :: StackDepth
556 -> [Id]
557 -> Word16
558 -> ProtoBCO Name
559 -> Word16
560 -> Word16
561 -> BcM BCInstrList
562 build_thunk _ [] size bco off arity
563 = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))
564 where
565 mkap | arity == 0 = MKAP
566 | otherwise = MKPAP
567 build_thunk dd (fv:fvs) size bco off arity = do
568 (push_code, pushed_szb) <- pushAtom dd p' (StgVarArg fv)
569 more_push_code <-
570 build_thunk (dd + pushed_szb) fvs size bco off arity
571 return (push_code `appOL` more_push_code)
572
573 alloc_code = toOL (zipWith mkAlloc sizes arities)
574 where mkAlloc sz 0
575 | is_tick = ALLOC_AP_NOUPD sz
576 | otherwise = ALLOC_AP sz
577 mkAlloc sz arity = ALLOC_PAP arity sz
578
579 is_tick = case binds of
580 StgNonRec id _ -> occNameFS (getOccName id) == tickFS
581 _other -> False
582
583 compile_bind d' fvs x (rhs::CgStgRhs) size arity off = do
584 bco <- schemeR fvs (getName x,rhs)
585 build_thunk d' fvs size bco off arity
586
587 compile_binds =
588 [ compile_bind d' fvs x rhs size arity (trunc16W n)
589 | (fvs, x, rhs, size, arity, n) <-
590 zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
591 ]
592 body_code <- schemeE d' s p' body
593 thunk_codes <- sequence compile_binds
594 return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
595
596 schemeE _d _s _p (StgTick (Breakpoint _ bp_id _) _rhs)
597 = panic ("schemeE: Breakpoint without let binding: " ++
598 show bp_id ++
599 " forgot to run bcPrep?")
600
601 -- ignore other kinds of tick
602 schemeE d s p (StgTick _ rhs) = schemeE d s p rhs
603
604 -- no alts: scrut is guaranteed to diverge
605 schemeE d s p (StgCase scrut _ _ []) = schemeE d s p scrut
606
607 schemeE d s p (StgCase scrut bndr _ alts)
608 = doCase d s p scrut bndr alts
609
610
611 {-
612 Ticked Expressions
613 ------------------
614
615 The idea is that the "breakpoint<n,fvs> E" is really just an annotation on
616 the code. When we find such a thing, we pull out the useful information,
617 and then compile the code as if it was just the expression E.
618 -}
619
620 -- Compile code to do a tail call. Specifically, push the fn,
621 -- slide the on-stack app back down to the sequel depth,
622 -- and enter. Four cases:
623 --
624 -- 0. (Nasty hack).
625 -- An application "GHC.Prim.tagToEnum# <type> unboxed-int".
626 -- The int will be on the stack. Generate a code sequence
627 -- to convert it to the relevant constructor, SLIDE and ENTER.
628 --
629 -- 1. The fn denotes a ccall. Defer to generateCCall.
630 --
631 -- 2. An unboxed tuple: push the components on the top of
632 -- the stack and return.
633 --
634 -- 3. Application of a constructor, by defn saturated.
635 -- Split the args into ptrs and non-ptrs, and push the nonptrs,
636 -- then the ptrs, and then do PACK and RETURN.
637 --
638 -- 4. Otherwise, it must be a function call. Push the args
639 -- right to left, SLIDE and ENTER.
640
641 schemeT :: StackDepth -- Stack depth
642 -> Sequel -- Sequel depth
643 -> BCEnv -- stack env
644 -> CgStgExpr
645 -> BcM BCInstrList
646
647 -- Case 0
648 schemeT d s p app
649 | Just (arg, constr_names) <- maybe_is_tagToEnum_call app
650 = implement_tagToId d s p arg constr_names
651
652 -- Case 1
653 schemeT d s p (StgOpApp (StgFCallOp (CCall ccall_spec) _ty) args result_ty)
654 = if isSupportedCConv ccall_spec
655 then generateCCall d s p ccall_spec result_ty (reverse args)
656 else unsupportedCConvException
657
658 schemeT d s p (StgOpApp (StgPrimOp op) args _ty)
659 = doTailCall d s p (primOpId op) (reverse args)
660
661 schemeT _d _s _p (StgOpApp StgPrimCallOp{} _args _ty)
662 = unsupportedCConvException
663
664 -- Case 2: Unboxed tuple
665 schemeT d s p (StgConApp con _ext args _tys)
666 | isUnboxedTupleDataCon con || isUnboxedSumDataCon con
667 = returnUnboxedTuple d s p args
668
669 -- Case 3: Ordinary data constructor
670 | otherwise
671 = do alloc_con <- mkConAppCode d s p con args
672 platform <- profilePlatform <$> getProfile
673 return (alloc_con `appOL`
674 mkSlideW 1 (bytesToWords platform $ d - s) `snocOL`
675 if isUnliftedTypeKind (tyConResKind (dataConTyCon con))
676 then RETURN_UNLIFTED P
677 else ENTER)
678
679 -- Case 4: Tail call of function
680 schemeT d s p (StgApp fn args)
681 = doTailCall d s p fn (reverse args)
682
683 schemeT _ _ _ e = pprPanic "GHC.StgToByteCode.schemeT"
684 (pprStgExpr shortStgPprOpts e)
685
686 -- -----------------------------------------------------------------------------
687 -- Generate code to build a constructor application,
688 -- leaving it on top of the stack
689
690 mkConAppCode
691 :: StackDepth
692 -> Sequel
693 -> BCEnv
694 -> DataCon -- The data constructor
695 -> [StgArg] -- Args, in *reverse* order
696 -> BcM BCInstrList
697 mkConAppCode orig_d _ p con args = app_code
698 where
699 app_code = do
700 profile <- getProfile
701 let platform = profilePlatform profile
702
703 non_voids =
704 [ NonVoid (prim_rep, arg)
705 | arg <- args
706 , let prim_rep = atomPrimRep arg
707 , not (isVoidRep prim_rep)
708 ]
709 (_, _, args_offsets) =
710 mkVirtHeapOffsetsWithPadding profile StdHeader non_voids
711
712 do_pushery !d (arg : args) = do
713 (push, arg_bytes) <- case arg of
714 (Padding l _) -> return $! pushPadding (ByteOff l)
715 (FieldOff a _) -> pushConstrAtom d p (fromNonVoid a)
716 more_push_code <- do_pushery (d + arg_bytes) args
717 return (push `appOL` more_push_code)
718 do_pushery !d [] = do
719 let !n_arg_words = trunc16W $ bytesToWords platform (d - orig_d)
720 return (unitOL (PACK con n_arg_words))
721
722 -- Push on the stack in the reverse order.
723 do_pushery orig_d (reverse args_offsets)
724
725 -- -----------------------------------------------------------------------------
726 -- Generate code for a tail-call
727
728 doTailCall
729 :: StackDepth
730 -> Sequel
731 -> BCEnv
732 -> Id
733 -> [StgArg]
734 -> BcM BCInstrList
735 doTailCall init_d s p fn args = do
736 platform <- profilePlatform <$> getProfile
737 do_pushes init_d args (map (atomRep platform) args)
738 where
739 do_pushes !d [] reps = do
740 assert (null reps ) return ()
741 (push_fn, sz) <- pushAtom d p (StgVarArg fn)
742 platform <- profilePlatform <$> getProfile
743 assert (sz == wordSize platform ) return ()
744 let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s)
745 enter = if isUnliftedType (idType fn)
746 then RETURN_UNLIFTED P
747 else ENTER
748 return (push_fn `appOL` (slide `appOL` unitOL enter))
749 do_pushes !d args reps = do
750 let (push_apply, n, rest_of_reps) = findPushSeq reps
751 (these_args, rest_of_args) = splitAt n args
752 (next_d, push_code) <- push_seq d these_args
753 platform <- profilePlatform <$> getProfile
754 instrs <- do_pushes (next_d + wordSize platform) rest_of_args rest_of_reps
755 -- ^^^ for the PUSH_APPLY_ instruction
756 return (push_code `appOL` (push_apply `consOL` instrs))
757
758 push_seq d [] = return (d, nilOL)
759 push_seq d (arg:args) = do
760 (push_code, sz) <- pushAtom d p arg
761 (final_d, more_push_code) <- push_seq (d + sz) args
762 return (final_d, push_code `appOL` more_push_code)
763
764 -- v. similar to CgStackery.findMatch, ToDo: merge
765 findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep])
766 findPushSeq (P: P: P: P: P: P: rest)
767 = (PUSH_APPLY_PPPPPP, 6, rest)
768 findPushSeq (P: P: P: P: P: rest)
769 = (PUSH_APPLY_PPPPP, 5, rest)
770 findPushSeq (P: P: P: P: rest)
771 = (PUSH_APPLY_PPPP, 4, rest)
772 findPushSeq (P: P: P: rest)
773 = (PUSH_APPLY_PPP, 3, rest)
774 findPushSeq (P: P: rest)
775 = (PUSH_APPLY_PP, 2, rest)
776 findPushSeq (P: rest)
777 = (PUSH_APPLY_P, 1, rest)
778 findPushSeq (V: rest)
779 = (PUSH_APPLY_V, 1, rest)
780 findPushSeq (N: rest)
781 = (PUSH_APPLY_N, 1, rest)
782 findPushSeq (F: rest)
783 = (PUSH_APPLY_F, 1, rest)
784 findPushSeq (D: rest)
785 = (PUSH_APPLY_D, 1, rest)
786 findPushSeq (L: rest)
787 = (PUSH_APPLY_L, 1, rest)
788 findPushSeq _
789 = panic "GHC.StgToByteCode.findPushSeq"
790
791 -- -----------------------------------------------------------------------------
792 -- Case expressions
793
794 doCase
795 :: StackDepth
796 -> Sequel
797 -> BCEnv
798 -> CgStgExpr
799 -> Id
800 -> [CgStgAlt]
801 -> BcM BCInstrList
802 doCase d s p scrut bndr alts
803 = do
804 profile <- getProfile
805 hsc_env <- getHscEnv
806 let
807 platform = profilePlatform profile
808
809 -- Are we dealing with an unboxed tuple with a tuple return frame?
810 --
811 -- 'Simple' tuples with at most one non-void component,
812 -- like (# Word# #) or (# Int#, State# RealWorld# #) do not have a
813 -- tuple return frame. This is because (# foo #) and (# foo, Void# #)
814 -- have the same runtime rep. We have more efficient specialized
815 -- return frames for the situations with one non-void element.
816
817 ubx_tuple_frame =
818 (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) &&
819 length non_void_arg_reps > 1
820
821 non_void_arg_reps = non_void (typeArgReps platform bndr_ty)
822
823 profiling
824 | Just interp <- hsc_interp hsc_env
825 = interpreterProfiled interp
826 | otherwise = False
827
828 -- Top of stack is the return itbl, as usual.
829 -- underneath it is the pointer to the alt_code BCO.
830 -- When an alt is entered, it assumes the returned value is
831 -- on top of the itbl.
832 ret_frame_size_b :: StackDepth
833 ret_frame_size_b | ubx_tuple_frame =
834 (if profiling then 5 else 4) * wordSize platform
835 | otherwise = 2 * wordSize platform
836
837 -- The stack space used to save/restore the CCCS when profiling
838 save_ccs_size_b | profiling &&
839 not ubx_tuple_frame = 2 * wordSize platform
840 | otherwise = 0
841
842 -- An unlifted value gets an extra info table pushed on top
843 -- when it is returned.
844 unlifted_itbl_size_b :: StackDepth
845 unlifted_itbl_size_b | ubx_tuple_frame = 3 * wordSize platform
846 | not (isUnliftedType bndr_ty) = 0
847 | otherwise = wordSize platform
848
849 (bndr_size, tuple_info, args_offsets)
850 | ubx_tuple_frame =
851 let bndr_ty = primRepCmmType platform
852 bndr_reps = filter (not.isVoidRep) (bcIdPrimReps bndr)
853 (tuple_info, args_offsets) =
854 layoutTuple profile 0 bndr_ty bndr_reps
855 in ( wordsToBytes platform (tupleSize tuple_info)
856 , tuple_info
857 , args_offsets
858 )
859 | otherwise = ( wordsToBytes platform (idSizeW platform bndr)
860 , voidTupleInfo
861 , []
862 )
863
864 -- depth of stack after the return value has been pushed
865 d_bndr =
866 d + ret_frame_size_b + bndr_size
867
868 -- depth of stack after the extra info table for an unlifted return
869 -- has been pushed, if any. This is the stack depth at the
870 -- continuation.
871 d_alts = d + ret_frame_size_b + bndr_size + unlifted_itbl_size_b
872
873 -- Env in which to compile the alts, not including
874 -- any vars bound by the alts themselves
875 p_alts = Map.insert bndr d_bndr p
876
877 bndr_ty = idType bndr
878 isAlgCase = isAlgType bndr_ty
879
880 -- given an alt, return a discr and code for it.
881 codeAlt (DEFAULT, _, rhs)
882 = do rhs_code <- schemeE d_alts s p_alts rhs
883 return (NoDiscr, rhs_code)
884
885 codeAlt alt@(_, bndrs, rhs)
886 -- primitive or nullary constructor alt: no need to UNPACK
887 | null real_bndrs = do
888 rhs_code <- schemeE d_alts s p_alts rhs
889 return (my_discr alt, rhs_code)
890 | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty =
891 let bndr_ty = primRepCmmType platform . bcIdPrimRep
892 tuple_start = d_bndr
893 (tuple_info, args_offsets) =
894 layoutTuple profile
895 0
896 bndr_ty
897 bndrs
898
899 stack_bot = d_alts
900
901 p' = Map.insertList
902 [ (arg, tuple_start -
903 wordsToBytes platform (tupleSize tuple_info) +
904 offset)
905 | (arg, offset) <- args_offsets
906 , not (isVoidRep $ bcIdPrimRep arg)]
907 p_alts
908 in do
909 rhs_code <- schemeE stack_bot s p' rhs
910 return (NoDiscr, rhs_code)
911 -- algebraic alt with some binders
912 | otherwise =
913 let (tot_wds, _ptrs_wds, args_offsets) =
914 mkVirtHeapOffsets profile NoHeader
915 [ NonVoid (bcIdPrimRep id, id)
916 | NonVoid id <- nonVoidIds real_bndrs
917 ]
918 size = WordOff tot_wds
919
920 stack_bot = d_alts + wordsToBytes platform size
921
922 -- convert offsets from Sp into offsets into the virtual stack
923 p' = Map.insertList
924 [ (arg, stack_bot - ByteOff offset)
925 | (NonVoid arg, offset) <- args_offsets ]
926 p_alts
927
928 -- unlifted datatypes have an infotable word on top
929 unpack = if isUnliftedType bndr_ty
930 then PUSH_L 1 `consOL`
931 UNPACK (trunc16W size) `consOL`
932 unitOL (SLIDE (trunc16W size) 1)
933 else unitOL (UNPACK (trunc16W size))
934 in do
935 massert isAlgCase
936 rhs_code <- schemeE stack_bot s p' rhs
937 return (my_discr alt, unpack `appOL` rhs_code)
938 where
939 real_bndrs = filterOut isTyVar bndrs
940
941 my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
942 my_discr (DataAlt dc, _, _)
943 | isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc
944 = NoDiscr
945 | otherwise
946 = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
947 my_discr (LitAlt l, _, _)
948 = case l of LitNumber LitNumInt i -> DiscrI (fromInteger i)
949 LitNumber LitNumWord w -> DiscrW (fromInteger w)
950 LitFloat r -> DiscrF (fromRational r)
951 LitDouble r -> DiscrD (fromRational r)
952 LitChar i -> DiscrI (ord i)
953 _ -> pprPanic "schemeE(StgCase).my_discr" (ppr l)
954
955 maybe_ncons
956 | not isAlgCase = Nothing
957 | otherwise
958 = case [dc | (DataAlt dc, _, _) <- alts] of
959 [] -> Nothing
960 (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
961
962 -- the bitmap is relative to stack depth d, i.e. before the
963 -- BCO, info table and return value are pushed on.
964 -- This bit of code is v. similar to buildLivenessMask in CgBindery,
965 -- except that here we build the bitmap from the known bindings of
966 -- things that are pointers, whereas in CgBindery the code builds the
967 -- bitmap from the free slots and unboxed bindings.
968 -- (ToDo: merge?)
969 --
970 -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002.
971 -- The bitmap must cover the portion of the stack up to the sequel only.
972 -- Previously we were building a bitmap for the whole depth (d), but we
973 -- really want a bitmap up to depth (d-s). This affects compilation of
974 -- case-of-case expressions, which is the only time we can be compiling a
975 -- case expression with s /= 0.
976
977 -- unboxed tuples get two more words, the second is a pointer (tuple_bco)
978 (extra_pointers, extra_slots)
979 | ubx_tuple_frame && profiling = ([1], 3) -- tuple_info, tuple_BCO, CCCS
980 | ubx_tuple_frame = ([1], 2) -- tuple_info, tuple_BCO
981 | otherwise = ([], 0)
982
983 bitmap_size = trunc16W $ fromIntegral extra_slots +
984 bytesToWords platform (d - s)
985
986 bitmap_size' :: Int
987 bitmap_size' = fromIntegral bitmap_size
988
989
990 pointers =
991 extra_pointers ++
992 sort (filter (< bitmap_size') (map (+extra_slots) rel_slots))
993 where
994 binds = Map.toList p
995 -- NB: unboxed tuple cases bind the scrut binder to the same offset
996 -- as one of the alt binders, so we have to remove any duplicates here:
997 rel_slots = nub $ map fromIntegral $ concatMap spread binds
998 spread (id, offset) | isUnboxedTupleType (idType id) ||
999 isUnboxedSumType (idType id) = []
1000 | isFollowableArg (bcIdArgRep platform id) = [ rel_offset ]
1001 | otherwise = []
1002 where rel_offset = trunc16W $ bytesToWords platform (d - offset)
1003
1004 bitmap = intsToReverseBitmap platform bitmap_size'{-size-} pointers
1005
1006 alt_stuff <- mapM codeAlt alts
1007 alt_final <- mkMultiBranch maybe_ncons alt_stuff
1008
1009 let
1010 alt_bco_name = getName bndr
1011 alt_bco = mkProtoBCO platform alt_bco_name alt_final (Left alts)
1012 0{-no arity-} bitmap_size bitmap True{-is alts-}
1013 scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b)
1014 (d + ret_frame_size_b + save_ccs_size_b)
1015 p scrut
1016 alt_bco' <- emitBc alt_bco
1017 if ubx_tuple_frame
1018 then do
1019 let args_ptrs =
1020 map (\(rep, off) -> (isFollowableArg (toArgRep platform rep), off))
1021 args_offsets
1022 tuple_bco <- emitBc (tupleBCO platform tuple_info args_ptrs)
1023 return (PUSH_ALTS_TUPLE alt_bco' tuple_info tuple_bco
1024 `consOL` scrut_code)
1025 else let push_alts
1026 | not (isUnliftedType bndr_ty)
1027 = PUSH_ALTS alt_bco'
1028 | otherwise
1029 = let unlifted_rep =
1030 case non_void_arg_reps of
1031 [] -> V
1032 [rep] -> rep
1033 _ -> panic "schemeE(StgCase).push_alts"
1034 in PUSH_ALTS_UNLIFTED alt_bco' unlifted_rep
1035 in return (push_alts `consOL` scrut_code)
1036
1037
1038 -- -----------------------------------------------------------------------------
1039 -- Deal with tuples
1040
1041 -- The native calling convention uses registers for tuples, but in the
1042 -- bytecode interpreter, all values live on the stack.
1043
1044 layoutTuple :: Profile
1045 -> ByteOff
1046 -> (a -> CmmType)
1047 -> [a]
1048 -> ( TupleInfo -- See Note [GHCi TupleInfo]
1049 , [(a, ByteOff)] -- argument, offset on stack
1050 )
1051 layoutTuple profile start_off arg_ty reps =
1052 let platform = profilePlatform profile
1053 (orig_stk_bytes, pos) = assignArgumentsPos profile
1054 0
1055 NativeReturn
1056 arg_ty
1057 reps
1058
1059 -- keep the stack parameters in the same place
1060 orig_stk_params = [(x, fromIntegral off) | (x, StackParam off) <- pos]
1061
1062 -- sort the register parameters by register and add them to the stack
1063 regs_order :: Map.Map GlobalReg Int
1064 regs_order = Map.fromList $ zip (tupleRegsCover platform) [0..]
1065
1066 reg_order :: GlobalReg -> (Int, GlobalReg)
1067 reg_order reg | Just n <- Map.lookup reg regs_order = (n, reg)
1068 -- a VanillaReg goes to the same place regardless of whether it
1069 -- contains a pointer
1070 reg_order (VanillaReg n VNonGcPtr) = reg_order (VanillaReg n VGcPtr)
1071 -- if we don't have a position for a FloatReg then they must be passed
1072 -- in the equivalent DoubleReg
1073 reg_order (FloatReg n) = reg_order (DoubleReg n)
1074 -- one-tuples can be passed in other registers, but then we don't need
1075 -- to care about the order
1076 reg_order reg = (0, reg)
1077
1078 (regs, reg_params)
1079 = unzip $ sortBy (comparing fst)
1080 [(reg_order reg, x) | (x, RegisterParam reg) <- pos]
1081
1082 (new_stk_bytes, new_stk_params) = assignStack platform
1083 orig_stk_bytes
1084 arg_ty
1085 reg_params
1086
1087 regs_set = mkRegSet (map snd regs)
1088
1089 get_byte_off (x, StackParam y) = (x, fromIntegral y)
1090 get_byte_off _ =
1091 panic "GHC.StgToByteCode.layoutTuple get_byte_off"
1092
1093 in ( TupleInfo
1094 { tupleSize = bytesToWords platform (ByteOff new_stk_bytes)
1095 , tupleRegs = regs_set
1096 , tupleNativeStackSize = bytesToWords platform
1097 (ByteOff orig_stk_bytes)
1098 }
1099 , sortBy (comparing snd) $
1100 map (\(x, o) -> (x, o + start_off))
1101 (orig_stk_params ++ map get_byte_off new_stk_params)
1102 )
1103
1104 {- Note [unboxed tuple bytecodes and tuple_BCO]
1105 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1106
1107 We have the bytecode instructions RETURN_TUPLE and PUSH_ALTS_TUPLE to
1108 return and receive arbitrary unboxed tuples, respectively. These
1109 instructions use the helper data tuple_BCO and tuple_info.
1110
1111 The helper data is used to convert tuples between GHCs native calling
1112 convention (object code), which uses stack and registers, and the bytecode
1113 calling convention, which only uses the stack. See Note [GHCi TupleInfo]
1114 for more details.
1115
1116
1117 Returning a tuple
1118 =================
1119
1120 Bytecode that returns a tuple first pushes all the tuple fields followed
1121 by the appropriate tuple_info and tuple_BCO onto the stack. It then
1122 executes the RETURN_TUPLE instruction, which causes the interpreter
1123 to push stg_ret_t_info to the top of the stack. The stack (growing down)
1124 then looks as follows:
1125
1126 ...
1127 next_frame
1128 tuple_field_1
1129 tuple_field_2
1130 ...
1131 tuple_field_n
1132 tuple_info
1133 tuple_BCO
1134 stg_ret_t_info <- Sp
1135
1136 If next_frame is bytecode, the interpreter will start executing it. If
1137 it's object code, the interpreter jumps back to the scheduler, which in
1138 turn jumps to stg_ret_t. stg_ret_t converts the tuple to the native
1139 calling convention using the description in tuple_info, and then jumps
1140 to next_frame.
1141
1142
1143 Receiving a tuple
1144 =================
1145
1146 Bytecode that receives a tuple uses the PUSH_ALTS_TUPLE instruction to
1147 push a continuation, followed by jumping to the code that produces the
1148 tuple. The PUSH_ALTS_TUPLE instuction contains three pieces of data:
1149
1150 * cont_BCO: the continuation that receives the tuple
1151 * tuple_info: see below
1152 * tuple_BCO: see below
1153
1154 The interpreter pushes these onto the stack when the PUSH_ALTS_TUPLE
1155 instruction is executed, followed by stg_ctoi_tN_info, with N depending
1156 on the number of stack words used by the tuple in the GHC native calling
1157 convention. N is derived from tuple_info.
1158
1159 For example if we expect a tuple with three words on the stack, the stack
1160 looks as follows after PUSH_ALTS_TUPLE:
1161
1162 ...
1163 next_frame
1164 cont_free_var_1
1165 cont_free_var_2
1166 ...
1167 cont_free_var_n
1168 tuple_info
1169 tuple_BCO
1170 cont_BCO
1171 stg_ctoi_t3_info <- Sp
1172
1173 If the tuple is returned by object code, stg_ctoi_t3 will deal with
1174 adjusting the stack pointer and converting the tuple to the bytecode
1175 calling convention. See Note [GHCi unboxed tuples stack spills] for more
1176 details.
1177
1178
1179 The tuple_BCO
1180 =============
1181
1182 The tuple_BCO is a helper bytecode object. Its main purpose is describing
1183 the contents of the stack frame containing the tuple for the storage
1184 manager. It contains only instructions to immediately return the tuple
1185 that is already on the stack.
1186
1187
1188 The tuple_info word
1189 ===================
1190
1191 The tuple_info word describes the stack and STG register (e.g. R1..R6,
1192 D1..D6) usage for the tuple. tuple_info contains enough information to
1193 convert the tuple between the stack-only bytecode and stack+registers
1194 GHC native calling conventions.
1195
1196 See Note [GHCi tuple layout] for more details of how the data is packed
1197 in a single word.
1198
1199 -}
1200
1201 tupleBCO :: Platform -> TupleInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
1202 tupleBCO platform info pointers =
1203 mkProtoBCO platform invented_name body_code (Left [])
1204 0{-no arity-} bitmap_size bitmap False{-is alts-}
1205
1206 where
1207 {-
1208 The tuple BCO is never referred to by name, so we can get away
1209 with using a fake name here. We will need to change this if we want
1210 to save some memory by sharing the BCO between places that have
1211 the same tuple shape
1212 -}
1213 invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "tuple")
1214
1215 -- the first word in the frame is the tuple_info word,
1216 -- which is not a pointer
1217 bitmap_size = trunc16W $ 1 + tupleSize info
1218 bitmap = intsToReverseBitmap platform (fromIntegral bitmap_size) $
1219 map ((+1) . fromIntegral . bytesToWords platform . snd)
1220 (filter fst pointers)
1221 body_code = mkSlideW 0 1 -- pop frame header
1222 `snocOL` RETURN_TUPLE -- and add it again
1223
1224 -- -----------------------------------------------------------------------------
1225 -- Deal with a CCall.
1226
1227 -- Taggedly push the args onto the stack R->L,
1228 -- deferencing ForeignObj#s and adjusting addrs to point to
1229 -- payloads in Ptr/Byte arrays. Then, generate the marshalling
1230 -- (machine) code for the ccall, and create bytecodes to call that and
1231 -- then return in the right way.
1232
1233 generateCCall
1234 :: StackDepth
1235 -> Sequel
1236 -> BCEnv
1237 -> CCallSpec -- where to call
1238 -> Type
1239 -> [StgArg] -- args (atoms)
1240 -> BcM BCInstrList
1241 generateCCall d0 s p (CCallSpec target cconv safety) result_ty args_r_to_l
1242 = do
1243 profile <- getProfile
1244
1245 let
1246 platform = profilePlatform profile
1247 -- useful constants
1248 addr_size_b :: ByteOff
1249 addr_size_b = wordSize platform
1250
1251 arrayish_rep_hdr_size :: TyCon -> Maybe Int
1252 arrayish_rep_hdr_size t
1253 | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
1254 = Just (arrPtrsHdrSize profile)
1255 | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon
1256 = Just (smallArrPtrsHdrSize profile)
1257 | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
1258 = Just (arrWordsHdrSize profile)
1259 | otherwise
1260 = Nothing
1261
1262 -- Get the args on the stack, with tags and suitably
1263 -- dereferenced for the CCall. For each arg, return the
1264 -- depth to the first word of the bits for that arg, and the
1265 -- ArgRep of what was actually pushed.
1266
1267 pargs
1268 :: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimRep)]
1269 pargs _ [] = return []
1270 pargs d (aa@(StgVarArg a):az)
1271 | Just t <- tyConAppTyCon_maybe (idType a)
1272 , Just hdr_sz <- arrayish_rep_hdr_size t
1273 -- Do magic for Ptr/Byte arrays. Push a ptr to the array on
1274 -- the stack but then advance it over the headers, so as to
1275 -- point to the payload.
1276 = do rest <- pargs (d + addr_size_b) az
1277 (push_fo, _) <- pushAtom d p aa
1278 -- The ptr points at the header. Advance it over the
1279 -- header and then pretend this is an Addr#.
1280 let code = push_fo `snocOL` SWIZZLE 0 (fromIntegral hdr_sz)
1281 return ((code, AddrRep) : rest)
1282 pargs d (aa:az) = do (code_a, sz_a) <- pushAtom d p aa
1283 rest <- pargs (d + sz_a) az
1284 return ((code_a, atomPrimRep aa) : rest)
1285
1286 code_n_reps <- pargs d0 args_r_to_l
1287 let
1288 (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
1289 a_reps_sizeW = sum (map (repSizeWords platform) a_reps_pushed_r_to_l)
1290
1291 push_args = concatOL pushs_arg
1292 !d_after_args = d0 + wordsToBytes platform a_reps_sizeW
1293 a_reps_pushed_RAW
1294 | null a_reps_pushed_r_to_l || not (isVoidRep (head a_reps_pushed_r_to_l))
1295 = panic "GHC.StgToByteCode.generateCCall: missing or invalid World token?"
1296 | otherwise
1297 = reverse (tail a_reps_pushed_r_to_l)
1298
1299 -- Now: a_reps_pushed_RAW are the reps which are actually on the stack.
1300 -- push_args is the code to do that.
1301 -- d_after_args is the stack depth once the args are on.
1302
1303 -- Get the result rep.
1304 (returns_void, r_rep)
1305 = case maybe_getCCallReturnRep result_ty of
1306 Nothing -> (True, VoidRep)
1307 Just rr -> (False, rr)
1308 {-
1309 Because the Haskell stack grows down, the a_reps refer to
1310 lowest to highest addresses in that order. The args for the call
1311 are on the stack. Now push an unboxed Addr# indicating
1312 the C function to call. Then push a dummy placeholder for the
1313 result. Finally, emit a CCALL insn with an offset pointing to the
1314 Addr# just pushed, and a literal field holding the mallocville
1315 address of the piece of marshalling code we generate.
1316 So, just prior to the CCALL insn, the stack looks like this
1317 (growing down, as usual):
1318
1319 <arg_n>
1320 ...
1321 <arg_1>
1322 Addr# address_of_C_fn
1323 <placeholder-for-result#> (must be an unboxed type)
1324
1325 The interpreter then calls the marshall code mentioned
1326 in the CCALL insn, passing it (& <placeholder-for-result#>),
1327 that is, the addr of the topmost word in the stack.
1328 When this returns, the placeholder will have been
1329 filled in. The placeholder is slid down to the sequel
1330 depth, and we RETURN.
1331
1332 This arrangement makes it simple to do f-i-dynamic since the Addr#
1333 value is the first arg anyway.
1334
1335 The marshalling code is generated specifically for this
1336 call site, and so knows exactly the (Haskell) stack
1337 offsets of the args, fn address and placeholder. It
1338 copies the args to the C stack, calls the stacked addr,
1339 and parks the result back in the placeholder. The interpreter
1340 calls it as a normal C call, assuming it has a signature
1341 void marshall_code ( StgWord* ptr_to_top_of_stack )
1342 -}
1343 -- resolve static address
1344 maybe_static_target :: Maybe Literal
1345 maybe_static_target =
1346 case target of
1347 DynamicTarget -> Nothing
1348 StaticTarget _ _ _ False ->
1349 panic "generateCCall: unexpected FFI value import"
1350 StaticTarget _ target _ True ->
1351 Just (LitLabel target mb_size IsFunction)
1352 where
1353 mb_size
1354 | OSMinGW32 <- platformOS platform
1355 , StdCallConv <- cconv
1356 = Just (fromIntegral a_reps_sizeW * platformWordSizeInBytes platform)
1357 | otherwise
1358 = Nothing
1359
1360 let
1361 is_static = isJust maybe_static_target
1362
1363 -- Get the arg reps, zapping the leading Addr# in the dynamic case
1364 a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
1365 | is_static = a_reps_pushed_RAW
1366 | otherwise = if null a_reps_pushed_RAW
1367 then panic "GHC.StgToByteCode.generateCCall: dyn with no args"
1368 else tail a_reps_pushed_RAW
1369
1370 -- push the Addr#
1371 (push_Addr, d_after_Addr)
1372 | Just machlabel <- maybe_static_target
1373 = (toOL [PUSH_UBX machlabel 1], d_after_args + addr_size_b)
1374 | otherwise -- is already on the stack
1375 = (nilOL, d_after_args)
1376
1377 -- Push the return placeholder. For a call returning nothing,
1378 -- this is a V (tag).
1379 r_sizeW = repSizeWords platform r_rep
1380 d_after_r = d_after_Addr + wordsToBytes platform r_sizeW
1381 push_r =
1382 if returns_void
1383 then nilOL
1384 else unitOL (PUSH_UBX (mkDummyLiteral platform r_rep) (trunc16W r_sizeW))
1385
1386 -- generate the marshalling code we're going to call
1387
1388 -- Offset of the next stack frame down the stack. The CCALL
1389 -- instruction needs to describe the chunk of stack containing
1390 -- the ccall args to the GC, so it needs to know how large it
1391 -- is. See comment in Interpreter.c with the CCALL instruction.
1392 stk_offset = trunc16W $ bytesToWords platform (d_after_r - s)
1393
1394 conv = case cconv of
1395 CCallConv -> FFICCall
1396 StdCallConv -> FFIStdCall
1397 _ -> panic "GHC.StgToByteCode: unexpected calling convention"
1398
1399 -- the only difference in libffi mode is that we prepare a cif
1400 -- describing the call type by calling libffi, and we attach the
1401 -- address of this to the CCALL instruction.
1402
1403
1404 let ffires = primRepToFFIType platform r_rep
1405 ffiargs = map (primRepToFFIType platform) a_reps
1406 interp <- hscInterp <$> getHscEnv
1407 token <- ioToBc $ interpCmd interp (PrepFFI conv ffiargs ffires)
1408 recordFFIBc token
1409
1410 let
1411 -- do the call
1412 do_call = unitOL (CCALL stk_offset token flags)
1413 where flags = case safety of
1414 PlaySafe -> 0x0
1415 PlayInterruptible -> 0x1
1416 PlayRisky -> 0x2
1417
1418 -- slide and return
1419 d_after_r_min_s = bytesToWords platform (d_after_r - s)
1420 wrapup = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW)
1421 `snocOL` RETURN_UNLIFTED (toArgRep platform r_rep)
1422 --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $
1423 return (
1424 push_args `appOL`
1425 push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
1426 )
1427
1428 primRepToFFIType :: Platform -> PrimRep -> FFIType
1429 primRepToFFIType platform r
1430 = case r of
1431 VoidRep -> FFIVoid
1432 IntRep -> signed_word
1433 WordRep -> unsigned_word
1434 Int8Rep -> FFISInt8
1435 Word8Rep -> FFIUInt8
1436 Int16Rep -> FFISInt16
1437 Word16Rep -> FFIUInt16
1438 Int32Rep -> FFISInt32
1439 Word32Rep -> FFIUInt32
1440 Int64Rep -> FFISInt64
1441 Word64Rep -> FFIUInt64
1442 AddrRep -> FFIPointer
1443 FloatRep -> FFIFloat
1444 DoubleRep -> FFIDouble
1445 LiftedRep -> FFIPointer
1446 UnliftedRep -> FFIPointer
1447 _ -> pprPanic "primRepToFFIType" (ppr r)
1448 where
1449 (signed_word, unsigned_word) = case platformWordSize platform of
1450 PW4 -> (FFISInt32, FFIUInt32)
1451 PW8 -> (FFISInt64, FFIUInt64)
1452
1453 -- Make a dummy literal, to be used as a placeholder for FFI return
1454 -- values on the stack.
1455 mkDummyLiteral :: Platform -> PrimRep -> Literal
1456 mkDummyLiteral platform pr
1457 = case pr of
1458 IntRep -> mkLitInt platform 0
1459 WordRep -> mkLitWord platform 0
1460 Int8Rep -> mkLitInt8 0
1461 Word8Rep -> mkLitWord8 0
1462 Int16Rep -> mkLitInt16 0
1463 Word16Rep -> mkLitWord16 0
1464 Int32Rep -> mkLitInt32 0
1465 Word32Rep -> mkLitWord32 0
1466 Int64Rep -> mkLitInt64 0
1467 Word64Rep -> mkLitWord64 0
1468 AddrRep -> LitNullAddr
1469 DoubleRep -> LitDouble 0
1470 FloatRep -> LitFloat 0
1471 LiftedRep -> LitNullAddr
1472 UnliftedRep -> LitNullAddr
1473 _ -> pprPanic "mkDummyLiteral" (ppr pr)
1474
1475
1476 -- Convert (eg)
1477 -- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
1478 -- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
1479 --
1480 -- to Just IntRep
1481 -- and check that an unboxed pair is returned wherein the first arg is V'd.
1482 --
1483 -- Alternatively, for call-targets returning nothing, convert
1484 --
1485 -- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
1486 -- -> (# GHC.Prim.State# GHC.Prim.RealWorld #)
1487 --
1488 -- to Nothing
1489
1490 maybe_getCCallReturnRep :: Type -> Maybe PrimRep
1491 maybe_getCCallReturnRep fn_ty
1492 = let
1493 (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
1494 r_reps = typePrimRepArgs r_ty
1495
1496 blargh :: a -- Used at more than one type
1497 blargh = pprPanic "maybe_getCCallReturn: can't handle:"
1498 (pprType fn_ty)
1499 in
1500 case r_reps of
1501 [] -> panic "empty typePrimRepArgs"
1502 [VoidRep] -> Nothing
1503 [rep] -> Just rep
1504
1505 -- if it was, it would be impossible to create a
1506 -- valid return value placeholder on the stack
1507 _ -> blargh
1508
1509 maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name])
1510 -- Detect and extract relevant info for the tagToEnum kludge.
1511 maybe_is_tagToEnum_call (StgOpApp (StgPrimOp TagToEnumOp) [StgVarArg v] t)
1512 = Just (v, extract_constr_Names t)
1513 where
1514 extract_constr_Names ty
1515 | rep_ty <- unwrapType ty
1516 , Just tyc <- tyConAppTyCon_maybe rep_ty
1517 , isDataTyCon tyc
1518 = map (getName . dataConWorkId) (tyConDataCons tyc)
1519 -- NOTE: use the worker name, not the source name of
1520 -- the DataCon. See "GHC.Core.DataCon" for details.
1521 | otherwise
1522 = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)
1523 maybe_is_tagToEnum_call _ = Nothing
1524
1525 {- -----------------------------------------------------------------------------
1526 Note [Implementing tagToEnum#]
1527 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1528 (implement_tagToId arg names) compiles code which takes an argument
1529 'arg', (call it i), and enters the i'th closure in the supplied list
1530 as a consequence. The [Name] is a list of the constructors of this
1531 (enumeration) type.
1532
1533 The code we generate is this:
1534 push arg
1535 push bogus-word
1536
1537 TESTEQ_I 0 L1
1538 PUSH_G <lbl for first data con>
1539 JMP L_Exit
1540
1541 L1: TESTEQ_I 1 L2
1542 PUSH_G <lbl for second data con>
1543 JMP L_Exit
1544 ...etc...
1545 Ln: TESTEQ_I n L_fail
1546 PUSH_G <lbl for last data con>
1547 JMP L_Exit
1548
1549 L_fail: CASEFAIL
1550
1551 L_exit: SLIDE 1 n
1552 ENTER
1553
1554 The 'bogus-word' push is because TESTEQ_I expects the top of the stack
1555 to have an info-table, and the next word to have the value to be
1556 tested. This is very weird, but it's the way it is right now. See
1557 Interpreter.c. We don't actually need an info-table here; we just
1558 need to have the argument to be one-from-top on the stack, hence pushing
1559 a 1-word null. See #8383.
1560 -}
1561
1562
1563 implement_tagToId
1564 :: StackDepth
1565 -> Sequel
1566 -> BCEnv
1567 -> Id
1568 -> [Name]
1569 -> BcM BCInstrList
1570 -- See Note [Implementing tagToEnum#]
1571 implement_tagToId d s p arg names
1572 = assert (notNull names) $
1573 do (push_arg, arg_bytes) <- pushAtom d p (StgVarArg arg)
1574 labels <- getLabelsBc (genericLength names)
1575 label_fail <- getLabelBc
1576 label_exit <- getLabelBc
1577 dflags <- getDynFlags
1578 let infos = zip4 labels (tail labels ++ [label_fail])
1579 [0 ..] names
1580 platform = targetPlatform dflags
1581 steps = map (mkStep label_exit) infos
1582 slide_ws = bytesToWords platform (d - s + arg_bytes)
1583
1584 return (push_arg
1585 `appOL` unitOL (PUSH_UBX LitNullAddr 1)
1586 -- Push bogus word (see Note [Implementing tagToEnum#])
1587 `appOL` concatOL steps
1588 `appOL` toOL [ LABEL label_fail, CASEFAIL,
1589 LABEL label_exit ]
1590 `appOL` mkSlideW 1 (slide_ws + 1)
1591 -- "+1" to account for bogus word
1592 -- (see Note [Implementing tagToEnum#])
1593 `appOL` unitOL ENTER)
1594 where
1595 mkStep l_exit (my_label, next_label, n, name_for_n)
1596 = toOL [LABEL my_label,
1597 TESTEQ_I n next_label,
1598 PUSH_G name_for_n,
1599 JMP l_exit]
1600
1601
1602 -- -----------------------------------------------------------------------------
1603 -- pushAtom
1604
1605 -- Push an atom onto the stack, returning suitable code & number of
1606 -- stack words used.
1607 --
1608 -- The env p must map each variable to the highest- numbered stack
1609 -- slot for it. For example, if the stack has depth 4 and we
1610 -- tagged-ly push (v :: Int#) on it, the value will be in stack[4],
1611 -- the tag in stack[5], the stack will have depth 6, and p must map v
1612 -- to 5 and not to 4. Stack locations are numbered from zero, so a
1613 -- depth 6 stack has valid words 0 .. 5.
1614
1615 pushAtom
1616 :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff)
1617
1618 -- See Note [Empty case alternatives] in GHC.Core
1619 -- and Note [Bottoming expressions] in GHC.Core.Utils:
1620 -- The scrutinee of an empty case evaluates to bottom
1621 pushAtom d p (StgVarArg var)
1622 | [] <- typePrimRep (idType var)
1623 = return (nilOL, 0)
1624
1625 | isFCallId var
1626 = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr var)
1627
1628 | Just primop <- isPrimOpId_maybe var
1629 = do
1630 platform <- targetPlatform <$> getDynFlags
1631 return (unitOL (PUSH_PRIMOP primop), wordSize platform)
1632
1633 | Just d_v <- lookupBCEnv_maybe var p -- var is a local variable
1634 = do platform <- targetPlatform <$> getDynFlags
1635
1636 let !szb = idSizeCon platform var
1637 with_instr instr = do
1638 let !off_b = trunc16B $ d - d_v
1639 return (unitOL (instr off_b), wordSize platform)
1640
1641 case szb of
1642 1 -> with_instr PUSH8_W
1643 2 -> with_instr PUSH16_W
1644 4 -> with_instr PUSH32_W
1645 _ -> do
1646 let !szw = bytesToWords platform szb
1647 !off_w = trunc16W $ bytesToWords platform (d - d_v) + szw - 1
1648 return (toOL (genericReplicate szw (PUSH_L off_w)),
1649 wordsToBytes platform szw)
1650 -- d - d_v offset from TOS to the first slot of the object
1651 --
1652 -- d - d_v + sz - 1 offset from the TOS of the last slot of the object
1653 --
1654 -- Having found the last slot, we proceed to copy the right number of
1655 -- slots on to the top of the stack.
1656
1657 | otherwise -- var must be a global variable
1658 = do topStrings <- getTopStrings
1659 platform <- targetPlatform <$> getDynFlags
1660 case lookupVarEnv topStrings var of
1661 Just ptr -> pushAtom d p $ StgLitArg $ mkLitWord platform $
1662 fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr
1663 Nothing -> do
1664 let sz = idSizeCon platform var
1665 massert (sz == wordSize platform)
1666 return (unitOL (PUSH_G (getName var)), sz)
1667
1668
1669 pushAtom _ _ (StgLitArg lit) = pushLiteral True lit
1670
1671 pushLiteral :: Bool -> Literal -> BcM (BCInstrList, ByteOff)
1672 pushLiteral padded lit =
1673 do
1674 platform <- targetPlatform <$> getDynFlags
1675 let code :: PrimRep -> BcM (BCInstrList, ByteOff)
1676 code rep =
1677 return (padding_instr `snocOL` instr, size_bytes + padding_bytes)
1678 where
1679 size_bytes = ByteOff $ primRepSizeB platform rep
1680
1681 -- Here we handle the non-word-width cases specifically since we
1682 -- must emit different bytecode for them.
1683
1684 round_to_words (ByteOff bytes) =
1685 ByteOff (roundUpToWords platform bytes)
1686
1687 padding_bytes
1688 | padded = round_to_words size_bytes - size_bytes
1689 | otherwise = 0
1690
1691 (padding_instr, _) = pushPadding padding_bytes
1692
1693 instr =
1694 case size_bytes of
1695 1 -> PUSH_UBX8 lit
1696 2 -> PUSH_UBX16 lit
1697 4 -> PUSH_UBX32 lit
1698 _ -> PUSH_UBX lit (trunc16W $ bytesToWords platform size_bytes)
1699
1700 case lit of
1701 LitLabel {} -> code AddrRep
1702 LitFloat {} -> code FloatRep
1703 LitDouble {} -> code DoubleRep
1704 LitChar {} -> code WordRep
1705 LitNullAddr -> code AddrRep
1706 LitString {} -> code AddrRep
1707 LitRubbish {} -> code WordRep
1708 LitNumber nt _ -> case nt of
1709 LitNumInt -> code IntRep
1710 LitNumWord -> code WordRep
1711 LitNumInt8 -> code Int8Rep
1712 LitNumWord8 -> code Word8Rep
1713 LitNumInt16 -> code Int16Rep
1714 LitNumWord16 -> code Word16Rep
1715 LitNumInt32 -> code Int32Rep
1716 LitNumWord32 -> code Word32Rep
1717 LitNumInt64 -> code Int64Rep
1718 LitNumWord64 -> code Word64Rep
1719 -- No LitNumBigNat should be left by the time this is called. CorePrep
1720 -- should have converted them all to a real core representation.
1721 LitNumBigNat -> panic "pushAtom: LitNumBigNat"
1722
1723 -- | Push an atom for constructor (i.e., PACK instruction) onto the stack.
1724 -- This is slightly different to @pushAtom@ due to the fact that we allow
1725 -- packing constructor fields. See also @mkConAppCode@ and @pushPadding@.
1726 pushConstrAtom
1727 :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff)
1728 pushConstrAtom _ _ (StgLitArg lit) = pushLiteral False lit
1729
1730 pushConstrAtom d p va@(StgVarArg v)
1731 | Just d_v <- lookupBCEnv_maybe v p = do -- v is a local variable
1732 platform <- targetPlatform <$> getDynFlags
1733 let !szb = idSizeCon platform v
1734 done instr = do
1735 let !off = trunc16B $ d - d_v
1736 return (unitOL (instr off), szb)
1737 case szb of
1738 1 -> done PUSH8
1739 2 -> done PUSH16
1740 4 -> done PUSH32
1741 _ -> pushAtom d p va
1742
1743 pushConstrAtom d p expr = pushAtom d p expr
1744
1745 pushPadding :: ByteOff -> (BCInstrList, ByteOff)
1746 pushPadding (ByteOff n) = go n (nilOL, 0)
1747 where
1748 go n acc@(!instrs, !off) = case n of
1749 0 -> acc
1750 1 -> (instrs `mappend` unitOL PUSH_PAD8, off + 1)
1751 2 -> (instrs `mappend` unitOL PUSH_PAD16, off + 2)
1752 3 -> go 1 (go 2 acc)
1753 4 -> (instrs `mappend` unitOL PUSH_PAD32, off + 4)
1754 _ -> go (n - 4) (go 4 acc)
1755
1756 -- -----------------------------------------------------------------------------
1757 -- Given a bunch of alts code and their discrs, do the donkey work
1758 -- of making a multiway branch using a switch tree.
1759 -- What a load of hassle!
1760
1761 mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt
1762 -- a hint; generates better code
1763 -- Nothing is always safe
1764 -> [(Discr, BCInstrList)]
1765 -> BcM BCInstrList
1766 mkMultiBranch maybe_ncons raw_ways = do
1767 lbl_default <- getLabelBc
1768
1769 let
1770 mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
1771 mkTree [] _range_lo _range_hi = return (unitOL (JMP lbl_default))
1772 -- shouldn't happen?
1773
1774 mkTree [val] range_lo range_hi
1775 | range_lo == range_hi
1776 = return (snd val)
1777 | null defaults -- Note [CASEFAIL]
1778 = do lbl <- getLabelBc
1779 return (testEQ (fst val) lbl
1780 `consOL` (snd val
1781 `appOL` (LABEL lbl `consOL` unitOL CASEFAIL)))
1782 | otherwise
1783 = return (testEQ (fst val) lbl_default `consOL` snd val)
1784
1785 -- Note [CASEFAIL] It may be that this case has no default
1786 -- branch, but the alternatives are not exhaustive - this
1787 -- happens for GADT cases for example, where the types
1788 -- prove that certain branches are impossible. We could
1789 -- just assume that the other cases won't occur, but if
1790 -- this assumption was wrong (because of a bug in GHC)
1791 -- then the result would be a segfault. So instead we
1792 -- emit an explicit test and a CASEFAIL instruction that
1793 -- causes the interpreter to barf() if it is ever
1794 -- executed.
1795
1796 mkTree vals range_lo range_hi
1797 = let n = length vals `div` 2
1798 vals_lo = take n vals
1799 vals_hi = drop n vals
1800 v_mid = fst (head vals_hi)
1801 in do
1802 label_geq <- getLabelBc
1803 code_lo <- mkTree vals_lo range_lo (dec v_mid)
1804 code_hi <- mkTree vals_hi v_mid range_hi
1805 return (testLT v_mid label_geq
1806 `consOL` (code_lo
1807 `appOL` unitOL (LABEL label_geq)
1808 `appOL` code_hi))
1809
1810 the_default
1811 = case defaults of
1812 [] -> nilOL
1813 [(_, def)] -> LABEL lbl_default `consOL` def
1814 _ -> panic "mkMultiBranch/the_default"
1815 instrs <- mkTree notd_ways init_lo init_hi
1816 return (instrs `appOL` the_default)
1817 where
1818 (defaults, not_defaults) = partition (isNoDiscr.fst) raw_ways
1819 notd_ways = sortBy (comparing fst) not_defaults
1820
1821 testLT (DiscrI i) fail_label = TESTLT_I i fail_label
1822 testLT (DiscrW i) fail_label = TESTLT_W i fail_label
1823 testLT (DiscrF i) fail_label = TESTLT_F i fail_label
1824 testLT (DiscrD i) fail_label = TESTLT_D i fail_label
1825 testLT (DiscrP i) fail_label = TESTLT_P i fail_label
1826 testLT NoDiscr _ = panic "mkMultiBranch NoDiscr"
1827
1828 testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label
1829 testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label
1830 testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label
1831 testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label
1832 testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label
1833 testEQ NoDiscr _ = panic "mkMultiBranch NoDiscr"
1834
1835 -- None of these will be needed if there are no non-default alts
1836 (init_lo, init_hi)
1837 | null notd_ways
1838 = panic "mkMultiBranch: awesome foursome"
1839 | otherwise
1840 = case fst (head notd_ways) of
1841 DiscrI _ -> ( DiscrI minBound, DiscrI maxBound )
1842 DiscrW _ -> ( DiscrW minBound, DiscrW maxBound )
1843 DiscrF _ -> ( DiscrF minF, DiscrF maxF )
1844 DiscrD _ -> ( DiscrD minD, DiscrD maxD )
1845 DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )
1846 NoDiscr -> panic "mkMultiBranch NoDiscr"
1847
1848 (algMinBound, algMaxBound)
1849 = case maybe_ncons of
1850 -- XXX What happens when n == 0?
1851 Just n -> (0, fromIntegral n - 1)
1852 Nothing -> (minBound, maxBound)
1853
1854 isNoDiscr NoDiscr = True
1855 isNoDiscr _ = False
1856
1857 dec (DiscrI i) = DiscrI (i-1)
1858 dec (DiscrW w) = DiscrW (w-1)
1859 dec (DiscrP i) = DiscrP (i-1)
1860 dec other = other -- not really right, but if you
1861 -- do cases on floating values, you'll get what you deserve
1862
1863 -- same snotty comment applies to the following
1864 minF, maxF :: Float
1865 minD, maxD :: Double
1866 minF = -1.0e37
1867 maxF = 1.0e37
1868 minD = -1.0e308
1869 maxD = 1.0e308
1870
1871
1872 -- -----------------------------------------------------------------------------
1873 -- Supporting junk for the compilation schemes
1874
1875 -- Describes case alts
1876 data Discr
1877 = DiscrI Int
1878 | DiscrW Word
1879 | DiscrF Float
1880 | DiscrD Double
1881 | DiscrP Word16
1882 | NoDiscr
1883 deriving (Eq, Ord)
1884
1885 instance Outputable Discr where
1886 ppr (DiscrI i) = int i
1887 ppr (DiscrW w) = text (show w)
1888 ppr (DiscrF f) = text (show f)
1889 ppr (DiscrD d) = text (show d)
1890 ppr (DiscrP i) = ppr i
1891 ppr NoDiscr = text "DEF"
1892
1893
1894 lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff
1895 lookupBCEnv_maybe = Map.lookup
1896
1897 idSizeW :: Platform -> Id -> WordOff
1898 idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep platform
1899
1900 idSizeCon :: Platform -> Id -> ByteOff
1901 idSizeCon platform var
1902 -- unboxed tuple components are padded to word size
1903 | isUnboxedTupleType (idType var) ||
1904 isUnboxedSumType (idType var) =
1905 wordsToBytes platform .
1906 WordOff . sum . map (argRepSizeW platform . toArgRep platform) .
1907 bcIdPrimReps $ var
1908 | otherwise = ByteOff (primRepSizeB platform (bcIdPrimRep var))
1909
1910 bcIdArgRep :: Platform -> Id -> ArgRep
1911 bcIdArgRep platform = toArgRep platform . bcIdPrimRep
1912
1913 bcIdPrimRep :: Id -> PrimRep
1914 bcIdPrimRep id
1915 | [rep] <- typePrimRepArgs (idType id)
1916 = rep
1917 | otherwise
1918 = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))
1919
1920
1921 bcIdPrimReps :: Id -> [PrimRep]
1922 bcIdPrimReps id = typePrimRepArgs (idType id)
1923
1924 repSizeWords :: Platform -> PrimRep -> WordOff
1925 repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep)
1926
1927 isFollowableArg :: ArgRep -> Bool
1928 isFollowableArg P = True
1929 isFollowableArg _ = False
1930
1931 -- | Indicate if the calling convention is supported
1932 isSupportedCConv :: CCallSpec -> Bool
1933 isSupportedCConv (CCallSpec _ cconv _) = case cconv of
1934 CCallConv -> True -- we explicitly pattern match on every
1935 StdCallConv -> True -- convention to ensure that a warning
1936 PrimCallConv -> False -- is triggered when a new one is added
1937 JavaScriptCallConv -> False
1938 CApiConv -> False
1939
1940 -- See bug #10462
1941 unsupportedCConvException :: a
1942 unsupportedCConvException = throwGhcException (ProgramError
1943 ("Error: bytecode compiler can't handle some foreign calling conventions\n"++
1944 " Workaround: use -fobject-code, or compile this module to .o separately."))
1945
1946 mkSlideB :: Platform -> ByteOff -> ByteOff -> OrdList BCInstr
1947 mkSlideB platform !nb !db = mkSlideW n d
1948 where
1949 !n = trunc16W $ bytesToWords platform nb
1950 !d = bytesToWords platform db
1951
1952 mkSlideW :: Word16 -> WordOff -> OrdList BCInstr
1953 mkSlideW !n !ws
1954 | ws > fromIntegral limit
1955 -- If the amount to slide doesn't fit in a Word16, generate multiple slide
1956 -- instructions
1957 = SLIDE n limit `consOL` mkSlideW n (ws - fromIntegral limit)
1958 | ws == 0
1959 = nilOL
1960 | otherwise
1961 = unitOL (SLIDE n $ fromIntegral ws)
1962 where
1963 limit :: Word16
1964 limit = maxBound
1965
1966 atomPrimRep :: StgArg -> PrimRep
1967 atomPrimRep (StgVarArg v) = bcIdPrimRep v
1968 atomPrimRep (StgLitArg l) = typePrimRep1 (literalType l)
1969
1970 atomRep :: Platform -> StgArg -> ArgRep
1971 atomRep platform e = toArgRep platform (atomPrimRep e)
1972
1973 -- | Let szsw be the sizes in bytes of some items pushed onto the stack, which
1974 -- has initial depth @original_depth@. Return the values which the stack
1975 -- environment should map these items to.
1976 mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
1977 mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb)
1978
1979 typeArgReps :: Platform -> Type -> [ArgRep]
1980 typeArgReps platform = map (toArgRep platform) . typePrimRepArgs
1981
1982 -- -----------------------------------------------------------------------------
1983 -- The bytecode generator's monad
1984
1985 data BcM_State
1986 = BcM_State
1987 { bcm_hsc_env :: HscEnv
1988 , thisModule :: Module -- current module (for breakpoints)
1989 , nextlabel :: Word32 -- for generating local labels
1990 , ffis :: [FFIInfo] -- ffi info blocks, to free later
1991 -- Should be free()d when it is GCd
1992 , modBreaks :: Maybe ModBreaks -- info about breakpoints
1993 , breakInfo :: IntMap CgBreakInfo
1994 , topStrings :: IdEnv (RemotePtr ()) -- top-level string literals
1995 -- See Note [generating code for top-level string literal bindings].
1996 }
1997
1998 newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor)
1999
2000 ioToBc :: IO a -> BcM a
2001 ioToBc io = BcM $ \st -> do
2002 x <- io
2003 return (st, x)
2004
2005 runBc :: HscEnv -> Module -> Maybe ModBreaks
2006 -> IdEnv (RemotePtr ())
2007 -> BcM r
2008 -> IO (BcM_State, r)
2009 runBc hsc_env this_mod modBreaks topStrings (BcM m)
2010 = m (BcM_State hsc_env this_mod 0 [] modBreaks IntMap.empty topStrings)
2011
2012 thenBc :: BcM a -> (a -> BcM b) -> BcM b
2013 thenBc (BcM expr) cont = BcM $ \st0 -> do
2014 (st1, q) <- expr st0
2015 let BcM k = cont q
2016 (st2, r) <- k st1
2017 return (st2, r)
2018
2019 thenBc_ :: BcM a -> BcM b -> BcM b
2020 thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do
2021 (st1, _) <- expr st0
2022 (st2, r) <- cont st1
2023 return (st2, r)
2024
2025 returnBc :: a -> BcM a
2026 returnBc result = BcM $ \st -> (return (st, result))
2027
2028 instance Applicative BcM where
2029 pure = returnBc
2030 (<*>) = ap
2031 (*>) = thenBc_
2032
2033 instance Monad BcM where
2034 (>>=) = thenBc
2035 (>>) = (*>)
2036
2037 instance HasDynFlags BcM where
2038 getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st))
2039
2040 getHscEnv :: BcM HscEnv
2041 getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st)
2042
2043 getProfile :: BcM Profile
2044 getProfile = targetProfile <$> getDynFlags
2045
2046 emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
2047 emitBc bco
2048 = BcM $ \st -> return (st{ffis=[]}, bco (ffis st))
2049
2050 recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()
2051 recordFFIBc a
2052 = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ())
2053
2054 getLabelBc :: BcM LocalLabel
2055 getLabelBc
2056 = BcM $ \st -> do let nl = nextlabel st
2057 when (nl == maxBound) $
2058 panic "getLabelBc: Ran out of labels"
2059 return (st{nextlabel = nl + 1}, LocalLabel nl)
2060
2061 getLabelsBc :: Word32 -> BcM [LocalLabel]
2062 getLabelsBc n
2063 = BcM $ \st -> let ctr = nextlabel st
2064 in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1])
2065
2066 getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre))
2067 getCCArray = BcM $ \st ->
2068 let breaks = expectJust "GHC.StgToByteCode.getCCArray" $ modBreaks st in
2069 return (st, modBreaks_ccs breaks)
2070
2071
2072 newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()
2073 newBreakInfo ix info = BcM $ \st ->
2074 return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ())
2075
2076 getCurrentModule :: BcM Module
2077 getCurrentModule = BcM $ \st -> return (st, thisModule st)
2078
2079 getTopStrings :: BcM (IdEnv (RemotePtr ()))
2080 getTopStrings = BcM $ \st -> return (st, topStrings st)
2081
2082 tickFS :: FastString
2083 tickFS = fsLit "ticked"