2 % (c) The University of Glasgow 2002-2006
5 ByteCodeGen: Generate bytecode from Core
8 module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
10 #include "HsVersions.h"
60 import qualified Data.Map as Map
61 import qualified FiniteMap as Map
63 -- -----------------------------------------------------------------------------
64 -- Generating byte code for a complete module
66 byteCodeGen :: DynFlags
70 -> IO CompiledByteCode
71 byteCodeGen dflags binds tycs modBreaks
72 = do showPass dflags "ByteCodeGen"
74 let flatBinds = [ (bndr, freeVars rhs)
75 | (bndr, rhs) <- flattenBinds binds]
77 us <- mkSplitUniqSupply 'y'
78 (BcM_State _us _final_ctr mallocd _, proto_bcos)
79 <- runBc us modBreaks (mapM schemeTopBind flatBinds)
81 when (notNull mallocd)
82 (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
84 dumpIfSet_dyn dflags Opt_D_dump_BCOs
85 "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
87 assembleBCOs dflags proto_bcos tycs
89 -- -----------------------------------------------------------------------------
90 -- Generating byte code for an expression
92 -- Returns: (the root BCO for this expression,
93 -- a list of auxilary BCOs resulting from compiling closures)
94 coreExprToBCOs :: DynFlags
97 coreExprToBCOs dflags expr
98 = do showPass dflags "ByteCodeGen"
100 -- create a totally bogus name for the top-level BCO; this
101 -- should be harmless, since it's never used for anything
102 let invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")
103 invented_id = Id.mkLocalId invented_name (panic "invented_id's type")
105 -- the uniques are needed to generate fresh variables when we introduce new
106 -- let bindings for ticked expressions
107 us <- mkSplitUniqSupply 'y'
108 (BcM_State _us _final_ctr mallocd _ , proto_bco)
109 <- runBc us emptyModBreaks (schemeTopBind (invented_id, freeVars expr))
111 when (notNull mallocd)
112 (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
114 dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)
116 assembleBCO dflags proto_bco
119 -- -----------------------------------------------------------------------------
120 -- Compilation schema for the bytecode generator
122 type BCInstrList = OrdList BCInstr
124 type Sequel = Word16 -- back off to this depth before ENTER
126 -- Maps Ids to the offset from the stack _base_ so we don't have
127 -- to mess with it after each push/pop.
128 type BCEnv = Map Id Word16 -- To find vars on the stack
131 ppBCEnv :: BCEnv -> SDoc
134 $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p))))
137 pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (idCgRep var)
138 cmp_snd x y = compare (snd x) (snd y)
141 -- Create a BCO and do a spot of peephole optimisation on the insns
146 -> Either [AnnAlt Id VarSet] (AnnExpr Id VarSet)
150 -> Bool -- True <=> is a return point, rather than a function
153 mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks
156 protoBCOInstrs = maybe_with_stack_check,
157 protoBCOBitmap = bitmap,
158 protoBCOBitmapSize = bitmap_size,
159 protoBCOArity = arity,
160 protoBCOExpr = origin,
161 protoBCOPtrs = mallocd_blocks
164 -- Overestimate the stack usage (in words) of this BCO,
165 -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit
166 -- stack check. (The interpreter always does a stack check
167 -- for iNTERP_STACK_CHECK_THRESH words at the start of each
168 -- BCO anyway, so we only need to add an explicit one in the
169 -- (hopefully rare) cases when the (overestimated) stack use
170 -- exceeds iNTERP_STACK_CHECK_THRESH.
171 maybe_with_stack_check
172 | is_ret && stack_usage < fromIntegral aP_STACK_SPLIM = peep_d
173 -- don't do stack checks at return points,
174 -- everything is aggregated up to the top BCO
175 -- (which must be a function).
176 -- That is, unless the stack usage is >= AP_STACK_SPLIM,
178 | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH
179 = STKCHECK stack_usage : peep_d
181 = peep_d -- the supposedly common case
183 -- We assume that this sum doesn't wrap
184 stack_usage = sum (map bciStackUse peep_d)
186 -- Merge local pushes
187 peep_d = peep (fromOL instrs_ordlist)
189 peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
190 = PUSH_LLL off1 (off2-1) (off3-2) : peep rest
191 peep (PUSH_L off1 : PUSH_L off2 : rest)
192 = PUSH_LL off1 (off2-1) : peep rest
198 argBits :: [CgRep] -> [Bool]
201 | isFollowableArg rep = False : argBits args
202 | otherwise = take (cgRepSizeW rep) (repeat True) ++ argBits args
204 -- -----------------------------------------------------------------------------
207 -- Compile code for the right-hand side of a top-level binding
209 schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name)
212 schemeTopBind (id, rhs)
213 | Just data_con <- isDataConWorkId_maybe id,
214 isNullaryRepDataCon data_con = do
215 -- Special case for the worker of a nullary data con.
216 -- It'll look like this: Nil = /\a -> Nil a
217 -- If we feed it into schemeR, we'll get
219 -- because mkConAppCode treats nullary constructor applications
220 -- by just re-using the single top-level definition. So
221 -- for the worker itself, we must allocate it directly.
222 -- ioToBc (putStrLn $ "top level BCO")
223 emitBc (mkProtoBCO (getName id) (toOL [PACK data_con 0, ENTER])
224 (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
227 = schemeR [{- No free variables -}] (id, rhs)
230 -- -----------------------------------------------------------------------------
233 -- Compile code for a right-hand side, to give a BCO that,
234 -- when executed with the free variables and arguments on top of the stack,
235 -- will return with a pointer to the result on top of the stack, after
236 -- removing the free variables and arguments.
238 -- Park the resulting BCO in the monad. Also requires the
239 -- variable to which this value was bound, so as to give the
240 -- resulting BCO a name.
242 schemeR :: [Id] -- Free vars of the RHS, ordered as they
243 -- will appear in the thunk. Empty for
244 -- top-level things, which have no free vars.
245 -> (Id, AnnExpr Id VarSet)
246 -> BcM (ProtoBCO Name)
247 schemeR fvs (nm, rhs)
251 $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
252 $$ pprCoreExpr (deAnnotate rhs)
258 = schemeR_wrk fvs nm rhs (collect rhs)
260 collect :: AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet)
261 collect (_, e) = go [] e
263 go xs e | Just e' <- bcView e = go xs e'
264 go xs (AnnLam x (_,e)) = go (x:xs) e
265 go xs not_lambda = (reverse xs, not_lambda)
267 schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name)
268 schemeR_wrk fvs nm original_body (args, body)
270 all_args = reverse args ++ fvs
271 arity = length all_args
272 -- all_args are the args in reverse order. We're compiling a function
273 -- \fv1..fvn x1..xn -> e
274 -- i.e. the fvs come first
276 szsw_args = map (fromIntegral . idSizeW) all_args
277 szw_args = sum szsw_args
278 p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args))
280 -- make the arg bitmap
281 bits = argBits (reverse (map idCgRep all_args))
282 bitmap_size = genericLength bits
283 bitmap = mkBitmap bits
285 body_code <- schemeER_wrk szw_args p_init body
287 emitBc (mkProtoBCO (getName nm) body_code (Right original_body)
288 arity bitmap_size bitmap False{-not alts-})
290 -- introduce break instructions for ticked expressions
291 schemeER_wrk :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
293 | Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do
294 code <- schemeE d 0 p newRhs
296 let idOffSets = getVarOffSets d p tickInfo
297 let tickNumber = tickInfo_number tickInfo
298 let breakInfo = BreakInfo
299 { breakInfo_module = tickInfo_module tickInfo
300 , breakInfo_number = tickNumber
301 , breakInfo_vars = idOffSets
302 , breakInfo_resty = exprType (deAnnotate' newRhs)
304 let breakInstr = case arr of
306 BRK_FUN arr# (fromIntegral tickNumber) breakInfo
307 return $ breakInstr `consOL` code
308 | otherwise = schemeE d 0 p rhs
310 getVarOffSets :: Word16 -> BCEnv -> TickInfo -> [(Id, Word16)]
311 getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals
313 getOffSet :: Word16 -> BCEnv -> Id -> Maybe (Id, Word16)
315 = case lookupBCEnv_maybe id env of
317 Just offset -> Just (id, d - offset)
319 fvsToEnv :: BCEnv -> VarSet -> [Id]
320 -- Takes the free variables of a right-hand side, and
321 -- delivers an ordered list of the local variables that will
322 -- be captured in the thunk for the RHS
323 -- The BCEnv argument tells which variables are in the local
324 -- environment: these are the ones that should be captured
326 -- The code that constructs the thunk, and the code that executes
327 -- it, have to agree about this layout
328 fvsToEnv p fvs = [v | v <- varSetElems fvs,
329 isId v, -- Could be a type variable
332 -- -----------------------------------------------------------------------------
337 { tickInfo_number :: Int -- the (module) unique number of the tick
338 , tickInfo_module :: Module -- the origin of the ticked expression
339 , tickInfo_locals :: [Id] -- the local vars in scope at the ticked expression
342 instance Outputable TickInfo where
343 ppr info = text "TickInfo" <+>
344 parens (int (tickInfo_number info) <+> ppr (tickInfo_module info) <+>
345 ppr (tickInfo_locals info))
347 -- Compile code to apply the given expression to the remaining args
348 -- on the stack, returning a HNF.
349 schemeE :: Word16 -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
352 | Just e' <- bcView e
355 -- Delegate tail-calls to schemeT.
356 schemeE d s p e@(AnnApp _ _)
359 schemeE d s p e@(AnnVar v)
360 | not (isUnLiftedType v_type)
361 = -- Lifted-type thing; push it in the normal way
365 = do -- Returning an unlifted value.
366 -- Heave it on the stack, SLIDE, and RETURN.
367 (push, szw) <- pushAtom d p (AnnVar v)
368 return (push -- value onto stack
369 `appOL` mkSLIDE szw (d-s) -- clear to sequel
370 `snocOL` RETURN_UBX v_rep) -- go
373 v_rep = typeCgRep v_type
375 schemeE d s p (AnnLit literal)
376 = do (push, szw) <- pushAtom d p (AnnLit literal)
377 let l_rep = typeCgRep (literalType literal)
378 return (push -- value onto stack
379 `appOL` mkSLIDE szw (d-s) -- clear to sequel
380 `snocOL` RETURN_UBX l_rep) -- go
382 schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
383 | (AnnVar v, args_r_to_l) <- splitApp rhs,
384 Just data_con <- isDataConWorkId_maybe v,
385 dataConRepArity data_con == length args_r_to_l
386 = do -- Special case for a non-recursive let whose RHS is a
387 -- saturatred constructor application.
388 -- Just allocate the constructor and carry on
389 alloc_code <- mkConAppCode d s p data_con args_r_to_l
390 body_code <- schemeE (d+1) s (Map.insert x d p) body
391 return (alloc_code `appOL` body_code)
393 -- General case for let. Generates correct, if inefficient, code in
395 schemeE d s p (AnnLet binds (_,body))
396 = let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
397 AnnRec xs_n_rhss -> unzip xs_n_rhss
398 n_binds = genericLength xs
400 fvss = map (fvsToEnv p' . fst) rhss
402 -- Sizes of free vars
403 sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW) rhs_fvs)) fvss
405 -- the arity of each rhs
406 arities = map (genericLength . fst . collect) rhss
408 -- This p', d' defn is safe because all the items being pushed
409 -- are ptrs, so all have size 1. d' and p' reflect the stack
410 -- after the closures have been allocated in the heap (but not
411 -- filled in), and pointers to them parked on the stack.
412 p' = Map.insertList (zipE xs (mkStackOffsets d (genericReplicate n_binds 1))) p
414 zipE = zipEqual "schemeE"
416 -- ToDo: don't build thunks for things with no free variables
417 build_thunk _ [] size bco off arity
418 = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))
420 mkap | arity == 0 = MKAP
422 build_thunk dd (fv:fvs) size bco off arity = do
423 (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)
424 more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off arity
425 return (push_code `appOL` more_push_code)
427 alloc_code = toOL (zipWith mkAlloc sizes arities)
429 | is_tick = ALLOC_AP_NOUPD sz
430 | otherwise = ALLOC_AP sz
431 mkAlloc sz arity = ALLOC_PAP arity sz
433 is_tick = case binds of
434 AnnNonRec id _ -> occNameFS (getOccName id) == tickFS
437 compile_bind d' fvs x rhs size arity off = do
438 bco <- schemeR fvs (x,rhs)
439 build_thunk d' fvs size bco off arity
442 [ compile_bind d' fvs x rhs size arity n
443 | (fvs, x, rhs, size, arity, n) <-
444 zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
447 body_code <- schemeE d' s p' body
448 thunk_codes <- sequence compile_binds
449 return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
451 -- introduce a let binding for a ticked case expression. This rule
452 -- *should* only fire when the expression was not already let-bound
453 -- (the code gen for let bindings should take care of that). Todo: we
454 -- call exprFreeVars on a deAnnotated expression, this may not be the
455 -- best way to calculate the free vars but it seemed like the least
456 -- intrusive thing to do
457 schemeE d s p exp@(AnnCase {})
458 | Just (_tickInfo, _rhs) <- isTickedExp' exp
459 = if isUnLiftedType ty
461 -- If the result type is unlifted, then we must generate
462 -- let f = \s . case tick# of _ -> e
464 -- When we stop at the breakpoint, _result will have an unlifted
465 -- type and hence won't be bound in the environment, but the
466 -- breakpoint will otherwise work fine.
467 id <- newId (mkFunTy realWorldStatePrimTy ty)
468 st <- newId realWorldStatePrimTy
469 let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyVarSet, exp)))
470 (emptyVarSet, (AnnApp (emptyVarSet, AnnVar id)
471 (emptyVarSet, AnnVar realWorldPrimId)))
475 -- Todo: is emptyVarSet correct on the next line?
476 let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyVarSet, AnnVar id)
478 where exp' = deAnnotate' exp
479 fvs = exprFreeVars exp'
482 schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1, bind2], rhs)])
483 | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1)
485 -- case .... of x { (# VoidArg'd-thing, a #) -> ... }
487 -- case .... of a { DEFAULT -> ... }
488 -- becuse the return convention for both are identical.
490 -- Note that it does not matter losing the void-rep thing from the
491 -- envt (it won't be bound now) because we never look such things up.
493 = --trace "automagic mashing of case alts (# VoidArg, a #)" $
494 doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
496 | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2)
497 = --trace "automagic mashing of case alts (# a, VoidArg #)" $
498 doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
500 schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1], rhs)])
501 | isUnboxedTupleCon dc
502 -- Similarly, convert
503 -- case .... of x { (# a #) -> ... }
505 -- case .... of a { DEFAULT -> ... }
506 = --trace "automagic mashing of case alts (# a #)" $
507 doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
509 schemeE d s p (AnnCase scrut bndr _ alts)
510 = doCase d s p scrut bndr alts False{-not an unboxed tuple-}
513 = pprPanic "ByteCodeGen.schemeE: unhandled case"
514 (pprCoreExpr (deAnnotate' expr))
520 A ticked expression looks like this:
522 case tick<n> var1 ... varN of DEFAULT -> e
524 (*) <n> is the number of the tick, which is unique within a module
525 (*) var1 ... varN are the local variables in scope at the tick site
527 If we find a ticked expression we return:
529 Just ((n, [var1 ... varN]), e)
531 otherwise we return Nothing.
533 The idea is that the "case tick<n> ..." is really just an annotation on
534 the code. When we find such a thing, we pull out the useful information,
535 and then compile the code as if it was just the expression "e".
539 isTickedExp' :: AnnExpr' Id a -> Maybe (TickInfo, AnnExpr Id a)
540 isTickedExp' (AnnCase scrut _bndr _type alts)
541 | Just tickInfo <- isTickedScrut scrut,
542 [(DEFAULT, _bndr, rhs)] <- alts
543 = Just (tickInfo, rhs)
545 isTickedScrut :: (AnnExpr Id a) -> Maybe TickInfo
548 Just (TickBox modName tickNumber) <- isTickBoxOp_maybe id
549 = Just $ TickInfo { tickInfo_number = tickNumber
550 , tickInfo_module = modName
551 , tickInfo_locals = idsOfArgs args
553 | otherwise = Nothing
555 (f, args) = collectArgs $ deAnnotate expr
556 idsOfArgs :: [Expr Id] -> [Id]
557 idsOfArgs = catMaybes . map exprId
558 exprId :: Expr Id -> Maybe Id
559 exprId (Var id) = Just id
562 isTickedExp' _ = Nothing
564 -- Compile code to do a tail call. Specifically, push the fn,
565 -- slide the on-stack app back down to the sequel depth,
566 -- and enter. Four cases:
569 -- An application "GHC.Prim.tagToEnum# <type> unboxed-int".
570 -- The int will be on the stack. Generate a code sequence
571 -- to convert it to the relevant constructor, SLIDE and ENTER.
573 -- 1. The fn denotes a ccall. Defer to generateCCall.
575 -- 2. (Another nasty hack). Spot (# a::VoidArg, b #) and treat
576 -- it simply as b -- since the representations are identical
577 -- (the VoidArg takes up zero stack space). Also, spot
578 -- (# b #) and treat it as b.
580 -- 3. Application of a constructor, by defn saturated.
581 -- Split the args into ptrs and non-ptrs, and push the nonptrs,
582 -- then the ptrs, and then do PACK and RETURN.
584 -- 4. Otherwise, it must be a function call. Push the args
585 -- right to left, SLIDE and ENTER.
587 schemeT :: Word16 -- Stack depth
588 -> Sequel -- Sequel depth
589 -> BCEnv -- stack env
590 -> AnnExpr' Id VarSet
595 -- | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
596 -- = panic "schemeT ?!?!"
598 -- | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate' app)) ++ "\n") False
602 | Just (arg, constr_names) <- maybe_is_tagToEnum_call
603 = do (push, arg_words) <- pushAtom d p arg
604 tagToId_sequence <- implement_tagToId constr_names
605 return (push `appOL` tagToId_sequence
606 `appOL` mkSLIDE 1 (d+arg_words-s)
610 | Just (CCall ccall_spec) <- isFCallId_maybe fn
611 = generateCCall d s p ccall_spec fn args_r_to_l
613 -- Case 2: Constructor application
614 | Just con <- maybe_saturated_dcon,
615 isUnboxedTupleCon con
616 = case args_r_to_l of
617 [arg1,arg2] | isVoidArgAtom arg1 ->
618 unboxedTupleReturn d s p arg2
619 [arg1,arg2] | isVoidArgAtom arg2 ->
620 unboxedTupleReturn d s p arg1
621 _other -> unboxedTupleException
623 -- Case 3: Ordinary data constructor
624 | Just con <- maybe_saturated_dcon
625 = do alloc_con <- mkConAppCode d s p con args_r_to_l
626 return (alloc_con `appOL`
627 mkSLIDE 1 (d - s) `snocOL`
630 -- Case 4: Tail call of function
632 = doTailCall d s p fn args_r_to_l
635 -- Detect and extract relevant info for the tagToEnum kludge.
636 maybe_is_tagToEnum_call
637 = let extract_constr_Names ty
638 | Just (tyc, _) <- splitTyConApp_maybe (repType ty),
640 = map (getName . dataConWorkId) (tyConDataCons tyc)
641 -- NOTE: use the worker name, not the source name of
642 -- the DataCon. See DataCon.lhs for details.
644 = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)
647 (AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
648 -> case isPrimOpId_maybe v of
649 Just TagToEnumOp -> Just (snd arg, extract_constr_Names t)
653 -- Extract the args (R->L) and fn
654 -- The function will necessarily be a variable,
655 -- because we are compiling a tail call
656 (AnnVar fn, args_r_to_l) = splitApp app
658 -- Only consider this to be a constructor application iff it is
659 -- saturated. Otherwise, we'll call the constructor wrapper.
660 n_args = length args_r_to_l
662 = case isDataConWorkId_maybe fn of
663 Just con | dataConRepArity con == n_args -> Just con
666 -- -----------------------------------------------------------------------------
667 -- Generate code to build a constructor application,
668 -- leaving it on top of the stack
670 mkConAppCode :: Word16 -> Sequel -> BCEnv
671 -> DataCon -- The data constructor
672 -> [AnnExpr' Id VarSet] -- Args, in *reverse* order
675 mkConAppCode _ _ _ con [] -- Nullary constructor
676 = ASSERT( isNullaryRepDataCon con )
677 return (unitOL (PUSH_G (getName (dataConWorkId con))))
678 -- Instead of doing a PACK, which would allocate a fresh
679 -- copy of this constructor, use the single shared version.
681 mkConAppCode orig_d _ p con args_r_to_l
682 = ASSERT( dataConRepArity con == length args_r_to_l )
683 do_pushery orig_d (non_ptr_args ++ ptr_args)
685 -- The args are already in reverse order, which is the way PACK
686 -- expects them to be. We must push the non-ptrs after the ptrs.
687 (ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l
689 do_pushery d (arg:args)
690 = do (push, arg_words) <- pushAtom d p arg
691 more_push_code <- do_pushery (d+arg_words) args
692 return (push `appOL` more_push_code)
694 = return (unitOL (PACK con n_arg_words))
696 n_arg_words = d - orig_d
699 -- -----------------------------------------------------------------------------
700 -- Returning an unboxed tuple with one non-void component (the only
701 -- case we can handle).
703 -- Remember, we don't want to *evaluate* the component that is being
704 -- returned, even if it is a pointed type. We always just return.
707 :: Word16 -> Sequel -> BCEnv
708 -> AnnExpr' Id VarSet -> BcM BCInstrList
709 unboxedTupleReturn d s p arg = do
710 (push, sz) <- pushAtom d p arg
712 mkSLIDE sz (d-s) `snocOL`
713 RETURN_UBX (atomRep arg))
715 -- -----------------------------------------------------------------------------
716 -- Generate code for a tail-call
719 :: Word16 -> Sequel -> BCEnv
720 -> Id -> [AnnExpr' Id VarSet]
722 doTailCall init_d s p fn args
723 = do_pushes init_d args (map atomRep args)
725 do_pushes d [] reps = do
726 ASSERT( null reps ) return ()
727 (push_fn, sz) <- pushAtom d p (AnnVar fn)
728 ASSERT( sz == 1 ) return ()
729 return (push_fn `appOL` (
730 mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL`
732 do_pushes d args reps = do
733 let (push_apply, n, rest_of_reps) = findPushSeq reps
734 (these_args, rest_of_args) = splitAt n args
735 (next_d, push_code) <- push_seq d these_args
736 instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps
737 -- ^^^ for the PUSH_APPLY_ instruction
738 return (push_code `appOL` (push_apply `consOL` instrs))
740 push_seq d [] = return (d, nilOL)
741 push_seq d (arg:args) = do
742 (push_code, sz) <- pushAtom d p arg
743 (final_d, more_push_code) <- push_seq (d+sz) args
744 return (final_d, push_code `appOL` more_push_code)
746 -- v. similar to CgStackery.findMatch, ToDo: merge
747 findPushSeq :: [CgRep] -> (BCInstr, Int, [CgRep])
748 findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
749 = (PUSH_APPLY_PPPPPP, 6, rest)
750 findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
751 = (PUSH_APPLY_PPPPP, 5, rest)
752 findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: rest)
753 = (PUSH_APPLY_PPPP, 4, rest)
754 findPushSeq (PtrArg: PtrArg: PtrArg: rest)
755 = (PUSH_APPLY_PPP, 3, rest)
756 findPushSeq (PtrArg: PtrArg: rest)
757 = (PUSH_APPLY_PP, 2, rest)
758 findPushSeq (PtrArg: rest)
759 = (PUSH_APPLY_P, 1, rest)
760 findPushSeq (VoidArg: rest)
761 = (PUSH_APPLY_V, 1, rest)
762 findPushSeq (NonPtrArg: rest)
763 = (PUSH_APPLY_N, 1, rest)
764 findPushSeq (FloatArg: rest)
765 = (PUSH_APPLY_F, 1, rest)
766 findPushSeq (DoubleArg: rest)
767 = (PUSH_APPLY_D, 1, rest)
768 findPushSeq (LongArg: rest)
769 = (PUSH_APPLY_L, 1, rest)
771 = panic "ByteCodeGen.findPushSeq"
773 -- -----------------------------------------------------------------------------
776 doCase :: Word16 -> Sequel -> BCEnv
777 -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
778 -> Bool -- True <=> is an unboxed tuple case, don't enter the result
780 doCase d s p (_,scrut) bndr alts is_unboxed_tuple
782 -- Top of stack is the return itbl, as usual.
783 -- underneath it is the pointer to the alt_code BCO.
784 -- When an alt is entered, it assumes the returned value is
785 -- on top of the itbl.
788 -- An unlifted value gets an extra info table pushed on top
789 -- when it is returned.
790 unlifted_itbl_sizeW | isAlgCase = 0
793 -- depth of stack after the return value has been pushed
794 d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW bndr)
796 -- depth of stack after the extra info table for an unboxed return
797 -- has been pushed, if any. This is the stack depth at the
799 d_alts = d_bndr + unlifted_itbl_sizeW
801 -- Env in which to compile the alts, not including
802 -- any vars bound by the alts themselves
803 p_alts = Map.insert bndr (d_bndr - 1) p
805 bndr_ty = idType bndr
806 isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple
808 -- given an alt, return a discr and code for it.
809 codeAlt (DEFAULT, _, (_,rhs))
810 = do rhs_code <- schemeE d_alts s p_alts rhs
811 return (NoDiscr, rhs_code)
813 codeAlt alt@(_, bndrs, (_,rhs))
814 -- primitive or nullary constructor alt: no need to UNPACK
815 | null real_bndrs = do
816 rhs_code <- schemeE d_alts s p_alts rhs
817 return (my_discr alt, rhs_code)
818 -- algebraic alt with some binders
821 (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs
822 ptr_sizes = map (fromIntegral . idSizeW) ptrs
823 nptrs_sizes = map (fromIntegral . idSizeW) nptrs
824 bind_sizes = ptr_sizes ++ nptrs_sizes
825 size = sum ptr_sizes + sum nptrs_sizes
826 -- the UNPACK instruction unpacks in reverse order...
828 (zip (reverse (ptrs ++ nptrs))
829 (mkStackOffsets d_alts (reverse bind_sizes)))
833 rhs_code <- schemeE (d_alts+size) s p' rhs
834 return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code)
836 real_bndrs = filterOut isTyVar bndrs
838 my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
839 my_discr (DataAlt dc, _, _)
840 | isUnboxedTupleCon dc
841 = unboxedTupleException
843 = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
844 my_discr (LitAlt l, _, _)
845 = case l of MachInt i -> DiscrI (fromInteger i)
846 MachWord w -> DiscrW (fromInteger w)
847 MachFloat r -> DiscrF (fromRational r)
848 MachDouble r -> DiscrD (fromRational r)
849 MachChar i -> DiscrI (ord i)
850 _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
853 | not isAlgCase = Nothing
855 = case [dc | (DataAlt dc, _, _) <- alts] of
857 (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
859 -- the bitmap is relative to stack depth d, i.e. before the
860 -- BCO, info table and return value are pushed on.
861 -- This bit of code is v. similar to buildLivenessMask in CgBindery,
862 -- except that here we build the bitmap from the known bindings of
863 -- things that are pointers, whereas in CgBindery the code builds the
864 -- bitmap from the free slots and unboxed bindings.
867 -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002.
868 -- The bitmap must cover the portion of the stack up to the sequel only.
869 -- Previously we were building a bitmap for the whole depth (d), but we
870 -- really want a bitmap up to depth (d-s). This affects compilation of
871 -- case-of-case expressions, which is the only time we can be compiling a
872 -- case expression with s /= 0.
875 bitmap_size' = fromIntegral bitmap_size
876 bitmap = intsToReverseBitmap bitmap_size'{-size-}
877 (sortLe (<=) (filter (< bitmap_size') rel_slots))
880 rel_slots = map fromIntegral $ concat (map spread binds)
882 | isFollowableArg (idCgRep id) = [ rel_offset ]
884 where rel_offset = d - offset - 1
887 alt_stuff <- mapM codeAlt alts
888 alt_final <- mkMultiBranch maybe_ncons alt_stuff
891 alt_bco_name = getName bndr
892 alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
893 0{-no arity-} bitmap_size bitmap True{-is alts-}
895 -- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
896 -- "\n bitmap = " ++ show bitmap) $ do
897 scrut_code <- schemeE (d + ret_frame_sizeW) (d + ret_frame_sizeW) p scrut
898 alt_bco' <- emitBc alt_bco
900 | isAlgCase = PUSH_ALTS alt_bco'
901 | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty)
902 return (push_alts `consOL` scrut_code)
905 -- -----------------------------------------------------------------------------
906 -- Deal with a CCall.
908 -- Taggedly push the args onto the stack R->L,
909 -- deferencing ForeignObj#s and adjusting addrs to point to
910 -- payloads in Ptr/Byte arrays. Then, generate the marshalling
911 -- (machine) code for the ccall, and create bytecodes to call that and
912 -- then return in the right way.
914 generateCCall :: Word16 -> Sequel -- stack and sequel depths
916 -> CCallSpec -- where to call
917 -> Id -- of target, for type info
918 -> [AnnExpr' Id VarSet] -- args (atoms)
921 generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
925 addr_sizeW = fromIntegral (cgRepSizeW NonPtrArg)
927 -- Get the args on the stack, with tags and suitably
928 -- dereferenced for the CCall. For each arg, return the
929 -- depth to the first word of the bits for that arg, and the
930 -- CgRep of what was actually pushed.
932 pargs _ [] = return []
934 = let arg_ty = repType (exprType (deAnnotate' a))
936 in case splitTyConApp_maybe arg_ty of
937 -- Don't push the FO; instead push the Addr# it
940 | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
941 -> do rest <- pargs (d + addr_sizeW) az
942 code <- parg_ArrayishRep (fromIntegral arrPtrsHdrSize) d p a
943 return ((code,AddrRep):rest)
945 | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
946 -> do rest <- pargs (d + addr_sizeW) az
947 code <- parg_ArrayishRep (fromIntegral arrWordsHdrSize) d p a
948 return ((code,AddrRep):rest)
950 -- Default case: push taggedly, but otherwise intact.
952 -> do (code_a, sz_a) <- pushAtom d p a
953 rest <- pargs (d+sz_a) az
954 return ((code_a, atomPrimRep a) : rest)
956 -- Do magic for Ptr/Byte arrays. Push a ptr to the array on
957 -- the stack but then advance it over the headers, so as to
958 -- point to the payload.
959 parg_ArrayishRep :: Word16 -> Word16 -> BCEnv -> AnnExpr' Id VarSet
961 parg_ArrayishRep hdrSize d p a
962 = do (push_fo, _) <- pushAtom d p a
963 -- The ptr points at the header. Advance it over the
964 -- header and then pretend this is an Addr#.
965 return (push_fo `snocOL` SWIZZLE 0 hdrSize)
968 code_n_reps <- pargs d0 args_r_to_l
970 (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
971 a_reps_sizeW = fromIntegral (sum (map primRepSizeW a_reps_pushed_r_to_l))
973 push_args = concatOL pushs_arg
974 d_after_args = d0 + a_reps_sizeW
976 | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep
977 = panic "ByteCodeGen.generateCCall: missing or invalid World token?"
979 = reverse (tail a_reps_pushed_r_to_l)
981 -- Now: a_reps_pushed_RAW are the reps which are actually on the stack.
982 -- push_args is the code to do that.
983 -- d_after_args is the stack depth once the args are on.
985 -- Get the result rep.
986 (returns_void, r_rep)
987 = case maybe_getCCallReturnRep (idType fn) of
988 Nothing -> (True, VoidRep)
989 Just rr -> (False, rr)
991 Because the Haskell stack grows down, the a_reps refer to
992 lowest to highest addresses in that order. The args for the call
993 are on the stack. Now push an unboxed Addr# indicating
994 the C function to call. Then push a dummy placeholder for the
995 result. Finally, emit a CCALL insn with an offset pointing to the
996 Addr# just pushed, and a literal field holding the mallocville
997 address of the piece of marshalling code we generate.
998 So, just prior to the CCALL insn, the stack looks like this
999 (growing down, as usual):
1004 Addr# address_of_C_fn
1005 <placeholder-for-result#> (must be an unboxed type)
1007 The interpreter then calls the marshall code mentioned
1008 in the CCALL insn, passing it (& <placeholder-for-result#>),
1009 that is, the addr of the topmost word in the stack.
1010 When this returns, the placeholder will have been
1011 filled in. The placeholder is slid down to the sequel
1012 depth, and we RETURN.
1014 This arrangement makes it simple to do f-i-dynamic since the Addr#
1015 value is the first arg anyway.
1017 The marshalling code is generated specifically for this
1018 call site, and so knows exactly the (Haskell) stack
1019 offsets of the args, fn address and placeholder. It
1020 copies the args to the C stack, calls the stacked addr,
1021 and parks the result back in the placeholder. The interpreter
1022 calls it as a normal C call, assuming it has a signature
1023 void marshall_code ( StgWord* ptr_to_top_of_stack )
1025 -- resolve static address
1029 -> return (False, panic "ByteCodeGen.generateCCall(dyn)")
1031 StaticTarget target _
1032 -> do res <- ioToBc (lookupStaticPtr stdcall_adj_target)
1036 #ifdef mingw32_TARGET_OS
1037 | StdCallConv <- cconv
1038 = let size = fromIntegral a_reps_sizeW * wORD_SIZE in
1039 mkFastString (unpackFS target ++ '@':show size)
1045 (is_static, static_target_addr) <- get_target_info
1048 -- Get the arg reps, zapping the leading Addr# in the dynamic case
1049 a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
1050 | is_static = a_reps_pushed_RAW
1051 | otherwise = if null a_reps_pushed_RAW
1052 then panic "ByteCodeGen.generateCCall: dyn with no args"
1053 else tail a_reps_pushed_RAW
1056 (push_Addr, d_after_Addr)
1058 = (toOL [PUSH_UBX (Right static_target_addr) addr_sizeW],
1059 d_after_args + addr_sizeW)
1060 | otherwise -- is already on the stack
1061 = (nilOL, d_after_args)
1063 -- Push the return placeholder. For a call returning nothing,
1064 -- this is a VoidArg (tag).
1065 r_sizeW = fromIntegral (primRepSizeW r_rep)
1066 d_after_r = d_after_Addr + r_sizeW
1067 r_lit = mkDummyLiteral r_rep
1068 push_r = (if returns_void
1070 else unitOL (PUSH_UBX (Left r_lit) r_sizeW))
1072 -- generate the marshalling code we're going to call
1074 -- Offset of the next stack frame down the stack. The CCALL
1075 -- instruction needs to describe the chunk of stack containing
1076 -- the ccall args to the GC, so it needs to know how large it
1077 -- is. See comment in Interpreter.c with the CCALL instruction.
1078 stk_offset = d_after_r - s
1081 -- the only difference in libffi mode is that we prepare a cif
1082 -- describing the call type by calling libffi, and we attach the
1083 -- address of this to the CCALL instruction.
1084 token <- ioToBc $ prepForeignCall cconv a_reps r_rep
1085 let addr_of_marshaller = castPtrToFunPtr token
1087 recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller))
1090 do_call = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller)
1091 (fromIntegral (fromEnum (playInterruptible safety))))
1093 wrapup = mkSLIDE r_sizeW (d_after_r - r_sizeW - s)
1094 `snocOL` RETURN_UBX (primRepToCgRep r_rep)
1096 --trace (show (arg1_offW, args_offW , (map cgRepSizeW a_reps) )) $
1099 push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
1102 -- Make a dummy literal, to be used as a placeholder for FFI return
1103 -- values on the stack.
1104 mkDummyLiteral :: PrimRep -> Literal
1108 WordRep -> MachWord 0
1109 AddrRep -> MachNullAddr
1110 DoubleRep -> MachDouble 0
1111 FloatRep -> MachFloat 0
1112 Int64Rep -> MachInt64 0
1113 Word64Rep -> MachWord64 0
1114 _ -> panic "mkDummyLiteral"
1118 -- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
1119 -- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
1122 -- and check that an unboxed pair is returned wherein the first arg is VoidArg'd.
1124 -- Alternatively, for call-targets returning nothing, convert
1126 -- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
1127 -- -> (# GHC.Prim.State# GHC.Prim.RealWorld #)
1131 maybe_getCCallReturnRep :: Type -> Maybe PrimRep
1132 maybe_getCCallReturnRep fn_ty
1133 = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
1135 = if isSingleton r_reps then Nothing else Just (r_reps !! 1)
1137 = case splitTyConApp_maybe (repType r_ty) of
1138 (Just (tyc, tys)) -> (tyc, map typePrimRep tys)
1140 ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps)
1141 || r_reps == [VoidRep] )
1142 && isUnboxedTupleTyCon r_tycon
1143 && case maybe_r_rep_to_go of
1145 Just r_rep -> r_rep /= PtrRep
1146 -- if it was, it would be impossible
1147 -- to create a valid return value
1148 -- placeholder on the stack
1150 blargh :: a -- Used at more than one type
1151 blargh = pprPanic "maybe_getCCallReturn: can't handle:"
1154 --trace (showSDoc (ppr (a_reps, r_reps))) $
1155 if ok then maybe_r_rep_to_go else blargh
1157 -- Compile code which expects an unboxed Int on the top of stack,
1158 -- (call it i), and pushes the i'th closure in the supplied list
1159 -- as a consequence.
1160 implement_tagToId :: [Name] -> BcM BCInstrList
1161 implement_tagToId names
1162 = ASSERT( notNull names )
1163 do labels <- getLabelsBc (genericLength names)
1164 label_fail <- getLabelBc
1165 label_exit <- getLabelBc
1166 let infos = zip4 labels (tail labels ++ [label_fail])
1168 steps = map (mkStep label_exit) infos
1169 return (concatOL steps
1171 toOL [LABEL label_fail, CASEFAIL, LABEL label_exit])
1173 mkStep l_exit (my_label, next_label, n, name_for_n)
1174 = toOL [LABEL my_label,
1175 TESTEQ_I n next_label,
1180 -- -----------------------------------------------------------------------------
1183 -- Push an atom onto the stack, returning suitable code & number of
1184 -- stack words used.
1186 -- The env p must map each variable to the highest- numbered stack
1187 -- slot for it. For example, if the stack has depth 4 and we
1188 -- tagged-ly push (v :: Int#) on it, the value will be in stack[4],
1189 -- the tag in stack[5], the stack will have depth 6, and p must map v
1190 -- to 5 and not to 4. Stack locations are numbered from zero, so a
1191 -- depth 6 stack has valid words 0 .. 5.
1193 pushAtom :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Word16)
1196 | Just e' <- bcView e
1199 pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things,
1200 = return (nilOL, 0) -- treated just like a variable VoidArg
1202 pushAtom d p (AnnVar v)
1203 | idCgRep v == VoidArg
1207 = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v)
1209 | Just primop <- isPrimOpId_maybe v
1210 = return (unitOL (PUSH_PRIMOP primop), 1)
1212 | Just d_v <- lookupBCEnv_maybe v p -- v is a local variable
1213 = let l = d - d_v + sz - 2
1214 in return (toOL (genericReplicate sz (PUSH_L l)), sz)
1215 -- d - d_v the number of words between the TOS
1216 -- and the 1st slot of the object
1218 -- d - d_v - 1 the offset from the TOS of the 1st slot
1220 -- d - d_v - 1 + sz - 1 the offset from the TOS of the last slot
1223 -- Having found the last slot, we proceed to copy the right number of
1224 -- slots on to the top of the stack.
1226 | otherwise -- v must be a global variable
1228 return (unitOL (PUSH_G (getName v)), sz)
1232 sz = fromIntegral (idSizeW v)
1235 pushAtom _ _ (AnnLit lit)
1237 MachLabel _ _ _ -> code NonPtrArg
1238 MachWord _ -> code NonPtrArg
1239 MachInt _ -> code PtrArg
1240 MachFloat _ -> code FloatArg
1241 MachDouble _ -> code DoubleArg
1242 MachChar _ -> code NonPtrArg
1243 MachNullAddr -> code NonPtrArg
1244 MachStr s -> pushStr s
1245 l -> pprPanic "pushAtom" (ppr l)
1248 = let size_host_words = fromIntegral (cgRepSizeW rep)
1249 in return (unitOL (PUSH_UBX (Left lit) size_host_words),
1253 = let getMallocvilleAddr
1255 FastString _ n _ fp _ ->
1256 -- we could grab the Ptr from the ForeignPtr,
1257 -- but then we have no way to control its lifetime.
1258 -- In reality it'll probably stay alive long enoungh
1259 -- by virtue of the global FastString table, but
1260 -- to be on the safe side we copy the string into
1261 -- a malloc'd area of memory.
1262 do ptr <- ioToBc (mallocBytes (n+1))
1265 withForeignPtr fp $ \p -> do
1266 memcpy ptr p (fromIntegral n)
1267 pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
1271 addr <- getMallocvilleAddr
1272 -- Get the addr on the stack, untaggedly
1273 return (unitOL (PUSH_UBX (Right addr) 1), 1)
1276 = pprPanic "ByteCodeGen.pushAtom"
1277 (pprCoreExpr (deAnnotate (undefined, expr)))
1279 foreign import ccall unsafe "memcpy"
1280 memcpy :: Ptr a -> Ptr b -> CSize -> IO ()
1283 -- -----------------------------------------------------------------------------
1284 -- Given a bunch of alts code and their discrs, do the donkey work
1285 -- of making a multiway branch using a switch tree.
1286 -- What a load of hassle!
1288 mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt
1289 -- a hint; generates better code
1290 -- Nothing is always safe
1291 -> [(Discr, BCInstrList)]
1293 mkMultiBranch maybe_ncons raw_ways
1294 = let d_way = filter (isNoDiscr.fst) raw_ways
1296 (\w1 w2 -> leAlt (fst w1) (fst w2))
1297 (filter (not.isNoDiscr.fst) raw_ways)
1299 mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
1300 mkTree [] _range_lo _range_hi = return the_default
1302 mkTree [val] range_lo range_hi
1303 | range_lo `eqAlt` range_hi
1306 = do label_neq <- getLabelBc
1307 return (testEQ (fst val) label_neq
1309 `appOL` unitOL (LABEL label_neq)
1310 `appOL` the_default))
1312 mkTree vals range_lo range_hi
1313 = let n = length vals `div` 2
1314 vals_lo = take n vals
1315 vals_hi = drop n vals
1316 v_mid = fst (head vals_hi)
1318 label_geq <- getLabelBc
1319 code_lo <- mkTree vals_lo range_lo (dec v_mid)
1320 code_hi <- mkTree vals_hi v_mid range_hi
1321 return (testLT v_mid label_geq
1323 `appOL` unitOL (LABEL label_geq)
1327 = case d_way of [] -> unitOL CASEFAIL
1329 _ -> panic "mkMultiBranch/the_default"
1331 testLT (DiscrI i) fail_label = TESTLT_I i fail_label
1332 testLT (DiscrW i) fail_label = TESTLT_W i fail_label
1333 testLT (DiscrF i) fail_label = TESTLT_F i fail_label
1334 testLT (DiscrD i) fail_label = TESTLT_D i fail_label
1335 testLT (DiscrP i) fail_label = TESTLT_P i fail_label
1336 testLT NoDiscr _ = panic "mkMultiBranch NoDiscr"
1338 testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label
1339 testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label
1340 testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label
1341 testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label
1342 testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label
1343 testEQ NoDiscr _ = panic "mkMultiBranch NoDiscr"
1345 -- None of these will be needed if there are no non-default alts
1348 = panic "mkMultiBranch: awesome foursome"
1350 = case fst (head notd_ways) of
1351 DiscrI _ -> ( DiscrI minBound, DiscrI maxBound )
1352 DiscrW _ -> ( DiscrW minBound, DiscrW maxBound )
1353 DiscrF _ -> ( DiscrF minF, DiscrF maxF )
1354 DiscrD _ -> ( DiscrD minD, DiscrD maxD )
1355 DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )
1356 NoDiscr -> panic "mkMultiBranch NoDiscr"
1358 (algMinBound, algMaxBound)
1359 = case maybe_ncons of
1360 -- XXX What happens when n == 0?
1361 Just n -> (0, fromIntegral n - 1)
1362 Nothing -> (minBound, maxBound)
1364 (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
1365 (DiscrW w1) `eqAlt` (DiscrW w2) = w1 == w2
1366 (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
1367 (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
1368 (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
1369 NoDiscr `eqAlt` NoDiscr = True
1372 (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
1373 (DiscrW w1) `leAlt` (DiscrW w2) = w1 <= w2
1374 (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
1375 (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
1376 (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
1377 NoDiscr `leAlt` NoDiscr = True
1380 isNoDiscr NoDiscr = True
1383 dec (DiscrI i) = DiscrI (i-1)
1384 dec (DiscrW w) = DiscrW (w-1)
1385 dec (DiscrP i) = DiscrP (i-1)
1386 dec other = other -- not really right, but if you
1387 -- do cases on floating values, you'll get what you deserve
1389 -- same snotty comment applies to the following
1391 minD, maxD :: Double
1397 mkTree notd_ways init_lo init_hi
1400 -- -----------------------------------------------------------------------------
1401 -- Supporting junk for the compilation schemes
1403 -- Describes case alts
1412 instance Outputable Discr where
1413 ppr (DiscrI i) = int i
1414 ppr (DiscrW w) = text (show w)
1415 ppr (DiscrF f) = text (show f)
1416 ppr (DiscrD d) = text (show d)
1417 ppr (DiscrP i) = ppr i
1418 ppr NoDiscr = text "DEF"
1421 lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word16
1422 lookupBCEnv_maybe = Map.lookup
1424 idSizeW :: Id -> Int
1425 idSizeW id = cgRepSizeW (typeCgRep (idType id))
1428 unboxedTupleException :: a
1429 unboxedTupleException
1432 ("Error: bytecode compiler can't handle unboxed tuples.\n"++
1433 " Possibly due to foreign import/export decls in source.\n"++
1434 " Workaround: use -fobject-code, or compile this module to .o separately."))
1437 mkSLIDE :: Word16 -> Word16 -> OrdList BCInstr
1438 mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
1440 splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])
1441 -- The arguments are returned in *right-to-left* order
1442 splitApp e | Just e' <- bcView e = splitApp e'
1443 splitApp (AnnApp (_,f) (_,a)) = case splitApp f of
1444 (f', as) -> (f', a:as)
1445 splitApp e = (e, [])
1448 bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
1449 -- The "bytecode view" of a term discards
1450 -- a) type abstractions
1451 -- b) type applications
1454 -- Type lambdas *can* occur in random expressions,
1455 -- whereas value lambdas cannot; that is why they are nuked here
1456 bcView (AnnNote _ (_,e)) = Just e
1457 bcView (AnnCast (_,e) _) = Just e
1458 bcView (AnnLam v (_,e)) | isTyVar v = Just e
1459 bcView (AnnApp (_,e) (_, AnnType _)) = Just e
1462 isVoidArgAtom :: AnnExpr' Var ann -> Bool
1463 isVoidArgAtom e | Just e' <- bcView e = isVoidArgAtom e'
1464 isVoidArgAtom (AnnVar v) = typePrimRep (idType v) == VoidRep
1465 isVoidArgAtom (AnnCoercion {}) = True
1466 isVoidArgAtom _ = False
1468 atomPrimRep :: AnnExpr' Id ann -> PrimRep
1469 atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
1470 atomPrimRep (AnnVar v) = typePrimRep (idType v)
1471 atomPrimRep (AnnLit l) = typePrimRep (literalType l)
1472 atomPrimRep (AnnCoercion {}) = VoidRep
1473 atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other)))
1475 atomRep :: AnnExpr' Id ann -> CgRep
1476 atomRep e = primRepToCgRep (atomPrimRep e)
1478 isPtrAtom :: AnnExpr' Id ann -> Bool
1479 isPtrAtom e = atomRep e == PtrArg
1481 -- Let szsw be the sizes in words of some items pushed onto the stack,
1482 -- which has initial depth d'. Return the values which the stack environment
1483 -- should map these items to.
1484 mkStackOffsets :: Word16 -> [Word16] -> [Word16]
1485 mkStackOffsets original_depth szsw
1486 = map (subtract 1) (tail (scanl (+) original_depth szsw))
1488 -- -----------------------------------------------------------------------------
1489 -- The bytecode generator's monad
1491 type BcPtr = Either ItblPtr (Ptr ())
1495 uniqSupply :: UniqSupply, -- for generating fresh variable names
1496 nextlabel :: Word16, -- for generating local labels
1497 malloced :: [BcPtr], -- thunks malloced for current BCO
1498 -- Should be free()d when it is GCd
1499 breakArray :: BreakArray -- array of breakpoint flags
1502 newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
1504 ioToBc :: IO a -> BcM a
1505 ioToBc io = BcM $ \st -> do
1509 runBc :: UniqSupply -> ModBreaks -> BcM r -> IO (BcM_State, r)
1510 runBc us modBreaks (BcM m)
1511 = m (BcM_State us 0 [] breakArray)
1513 breakArray = modBreaks_flags modBreaks
1515 thenBc :: BcM a -> (a -> BcM b) -> BcM b
1516 thenBc (BcM expr) cont = BcM $ \st0 -> do
1517 (st1, q) <- expr st0
1522 thenBc_ :: BcM a -> BcM b -> BcM b
1523 thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do
1524 (st1, _) <- expr st0
1525 (st2, r) <- cont st1
1528 returnBc :: a -> BcM a
1529 returnBc result = BcM $ \st -> (return (st, result))
1531 instance Monad BcM where
1536 emitBc :: ([BcPtr] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
1538 = BcM $ \st -> return (st{malloced=[]}, bco (malloced st))
1540 recordMallocBc :: Ptr a -> BcM ()
1542 = BcM $ \st -> return (st{malloced = Right (castPtr a) : malloced st}, ())
1544 recordItblMallocBc :: ItblPtr -> BcM ()
1545 recordItblMallocBc a
1546 = BcM $ \st -> return (st{malloced = Left a : malloced st}, ())
1548 getLabelBc :: BcM Word16
1550 = BcM $ \st -> do let nl = nextlabel st
1551 when (nl == maxBound) $
1552 panic "getLabelBc: Ran out of labels"
1553 return (st{nextlabel = nl + 1}, nl)
1555 getLabelsBc :: Word16 -> BcM [Word16]
1557 = BcM $ \st -> let ctr = nextlabel st
1558 in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
1560 getBreakArray :: BcM BreakArray
1561 getBreakArray = BcM $ \st -> return (st, breakArray st)
1563 newUnique :: BcM Unique
1565 \st -> case takeUniqFromSupply (uniqSupply st) of
1566 (uniq, us) -> let newState = st { uniqSupply = us }
1567 in return (newState, uniq)
1569 newId :: Type -> BcM Id
1572 return $ mkSysLocal tickFS uniq ty
1574 tickFS :: FastString
1575 tickFS = fsLit "ticked"