import Outputable
import Name ( Name, getName, mkSysLocalName )
import Id ( Id, idType, isDataConId_maybe, mkVanillaId,
- isPrimOpId_maybe )
+ isPrimOpId_maybe, idPrimRep )
import OrdList ( OrdList, consOL, snocOL, appOL, unitOL,
nilOL, toOL, concatOL, fromOL )
import FiniteMap ( FiniteMap, addListToFM, listToFM,
import PrimOp ( PrimOp(..) )
import CoreFVs ( freeVars )
import Type ( typePrimRep )
-import DataCon ( dataConTag, fIRST_TAG, dataConTyCon, dataConWrapId )
+import DataCon ( dataConTag, fIRST_TAG, dataConTyCon,
+ dataConWrapId, isUnboxedTupleCon )
import TyCon ( TyCon, tyConFamilySize )
import Class ( Class, classTyCon )
import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem )
import ErrUtils ( showPass, dumpIfSet_dyn )
import Unique ( mkPseudoUnique3 )
import FastString ( FastString(..) )
+import Panic ( GhcException(..) )
import PprType ( pprType )
-import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO )
+import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse )
import ByteCodeItbls ( ItblEnv, mkITbls )
import ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO,
- ClosureEnv, HValue, linkSomeBCOs, filterNameMap )
+ ClosureEnv, HValue, linkSomeBCOs, filterNameMap,
+ iNTERP_STACK_CHECK_THRESH )
import List ( intersperse, sortBy )
import Foreign ( Ptr(..), mallocBytes )
import Addr ( Addr(..), addrToInt, writeCharOffAddr )
import CTypes ( CInt )
+import Exception ( throwDyn )
import PrelBase ( Int(..) )
import PrelGHC ( ByteArray# )
= do let (bcoss, ies) = unzip mods
bcos = concat bcoss
final_gie = foldr plusFM gie ies
- (final_gce, linked_bcos) <- linkSomeBCOs final_gie gce bcos
+ (final_gce, linked_bcos) <- linkSomeBCOs True final_gie gce bcos
return (linked_bcos, final_gie, final_gce)
linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr
-> IO HValue -- IO BCO# really
linkIExpr ie ce (root_ul_bco, aux_ul_bcos)
- = do (aux_ce, _) <- linkSomeBCOs ie ce aux_ul_bcos
- (_, [root_bco]) <- linkSomeBCOs ie aux_ce [root_ul_bco]
+ = do (aux_ce, _) <- linkSomeBCOs False ie ce aux_ul_bcos
+ (_, [root_bco]) <- linkSomeBCOs False ie aux_ce [root_ul_bco]
return root_bco
\end{code}
-- Create a BCO and do a spot of peephole optimisation on the insns
-- at the same time.
mkProtoBCO nm instrs_ordlist origin
- = ProtoBCO nm (id {-peep-} (fromOL instrs_ordlist)) origin
+ = ProtoBCO nm maybe_with_stack_check origin
where
+ -- Overestimate the stack usage (in words) of this BCO,
+ -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit
+ -- stack check. (The interpreter always does a stack check
+ -- for iNTERP_STACK_CHECK_THRESH words at the start of each
+ -- BCO anyway, so we only need to add an explicit on in the
+ -- (hopefully rare) cases when the (overestimated) stack use
+ -- exceeds iNTERP_STACK_CHECK_THRESH.
+ maybe_with_stack_check
+ | stack_overest >= 65535
+ = pprPanic "mkProtoBCO: stack use won't fit in 16 bits"
+ (int stack_overest)
+ | stack_overest >= iNTERP_STACK_CHECK_THRESH
+ = (STKCHECK stack_overest) : peep_d
+ | otherwise
+ = peep_d -- the supposedly common case
+
+ stack_overest = sum (map bciStackUse peep_d)
+ + 10 {- just to be really really sure -}
+
+
+ -- Merge local pushes
+ peep_d = peep (fromOL instrs_ordlist)
+
peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
= PUSH_LLL off1 (off2-1) (off3-2) : peep rest
peep (PUSH_L off1 : PUSH_L off2 : rest)
- = PUSH_LL off1 off2 : peep rest
+ = PUSH_LL off1 (off2-1) : peep rest
peep (i:rest)
= i : peep rest
peep []
scrut_primrep = typePrimRep (idType bndr)
isAlgCase
= case scrut_primrep of
- CharRep -> False ; AddrRep -> False
+ CharRep -> False ; AddrRep -> False ; WordRep -> False
IntRep -> False ; FloatRep -> False ; DoubleRep -> False
PtrRep -> True
other -> pprPanic "ByteCodeGen.schemeE" (ppr other)
schemeE d' s p' rhs `thenBc` \ rhs_code ->
returnBc (my_discr alt, rhs_code)
- my_discr (DEFAULT, binds, rhs) = NoDiscr
- my_discr (DataAlt dc, binds, rhs) = DiscrP (dataConTag dc - fIRST_TAG)
+ my_discr (DEFAULT, binds, rhs) = NoDiscr
+ my_discr (DataAlt dc, binds, rhs)
+ | isUnboxedTupleCon dc
+ = unboxedTupleException
+ | otherwise
+ = DiscrP (dataConTag dc - fIRST_TAG)
my_discr (LitAlt l, binds, rhs)
= case l of MachInt i -> DiscrI (fromInteger i)
MachFloat r -> DiscrF (fromRational r)
-- Cases 2 and 3
| otherwise
- = code
+ = if is_con_call && isUnboxedTupleCon con
+ then unboxedTupleException
+ else code
where
-- Extract the args (R->L) and fn
(args_r_to_l_raw, fn) = chomp app
chomp expr
= case snd expr of
- AnnVar v -> ([], v)
- AnnApp f a -> case chomp f of (az, f) -> (snd a:az, f)
- other -> pprPanic "schemeT"
- (ppr (deAnnotate (panic "schemeT.chomp", other)))
+ AnnVar v -> ([], v)
+ AnnApp f a -> case chomp f of (az, f) -> (snd a:az, f)
+ AnnNote n e -> chomp e
+ other -> pprPanic "schemeT"
+ (ppr (deAnnotate (panic "schemeT.chomp", other)))
args_r_to_l = filter (not.isTypeAtom) args_r_to_l_raw
isTypeAtom (AnnType _) = True
atomRep (AnnLit l) = literalPrimRep l
atomRep (AnnNote n b) = atomRep (snd b)
atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f)
+atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
pushAtom :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> (BCInstrList, Int)
pushAtom tagged d p (AnnVar v)
+
+ | idPrimRep v == VoidRep
+ = ASSERT(tagged)
+ (unitOL (PUSH_TAG 0), 1)
+
| Just primop <- isPrimOpId_maybe v
= case primop of
CCallOp _ -> panic "pushAtom: byte code generator can't handle CCalls"
pushAtom False d p (AnnLit lit)
= case lit of
+ MachWord w -> code WordRep
MachInt i -> code IntRep
MachFloat r -> code FloatRep
MachDouble r -> code DoubleRep
pushAtom tagged d p (AnnNote note e)
= pushAtom tagged d p (snd e)
+pushAtom tagged d p (AnnLam x e)
+ | isTyVar x
+ = pushAtom tagged d p (snd e)
+
pushAtom tagged d p other
= pprPanic "ByteCodeGen.pushAtom"
(pprCoreExpr (deAnnotate (undefined, other)))
taggedIdSizeW = taggedSizeW . typePrimRep . idType
untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
+unboxedTupleException :: a
+unboxedTupleException
+ = throwDyn (Panic "bytecode generator can't handle unboxed tuples")
+
\end{code}
%************************************************************************