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