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