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