| Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do
code <- schemeE d 0 p newRhs
arr <- getBreakArray
- let idOffSets = getVarOffSets (fromIntegral d) p tickInfo
+ let idOffSets = getVarOffSets d p tickInfo
let tickNumber = tickInfo_number tickInfo
let breakInfo = BreakInfo
{ breakInfo_module = tickInfo_module tickInfo
-- Detect and extract relevant info for the tagToEnum kludge.
maybe_is_tagToEnum_call
= let extract_constr_Names ty
- | Just (tyc, []) <- splitTyConApp_maybe (repType ty),
+ | Just (tyc, _) <- splitTyConApp_maybe (repType ty),
isDataTyCon tyc
= map (getName . dataConWorkId) (tyConDataCons tyc)
-- NOTE: use the worker name, not the source name of
-- the DataCon. See DataCon.lhs for details.
| otherwise
- = panic "maybe_is_tagToEnum_call.extract_constr_Ids"
+ = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)
in
case app of
(AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
-> [AnnExpr' Id VarSet] -- args (atoms)
-> BcM BCInstrList
-generateCCall d0 s p (CCallSpec target cconv _) fn args_r_to_l
+generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
= let
-- useful constants
addr_sizeW :: Word16
recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller))
let
-- do the call
- do_call = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller))
+ do_call = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller)
+ (fromIntegral (fromEnum (playInterruptible safety))))
-- slide and return
wrapup = mkSLIDE r_sizeW (d_after_r - r_sizeW - s)
`snocOL` RETURN_UBX (primRepToCgRep r_rep)
= return (snd val)
| otherwise
= do label_neq <- getLabelBc
- return (mkTestEQ (fst val) label_neq
+ return (testEQ (fst val) label_neq
`consOL` (snd val
`appOL` unitOL (LABEL label_neq)
`appOL` the_default))
label_geq <- getLabelBc
code_lo <- mkTree vals_lo range_lo (dec v_mid)
code_hi <- mkTree vals_hi v_mid range_hi
- return (mkTestLT v_mid label_geq
+ return (testLT v_mid label_geq
`consOL` (code_lo
`appOL` unitOL (LABEL label_geq)
`appOL` code_hi))
[(_, def)] -> def
_ -> panic "mkMultiBranch/the_default"
+ testLT (DiscrI i) fail_label = TESTLT_I i fail_label
+ testLT (DiscrW i) fail_label = TESTLT_W i fail_label
+ testLT (DiscrF i) fail_label = TESTLT_F i fail_label
+ testLT (DiscrD i) fail_label = TESTLT_D i fail_label
+ testLT (DiscrP i) fail_label = TESTLT_P i fail_label
+ testLT NoDiscr _ = panic "mkMultiBranch NoDiscr"
+
+ testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label
+ testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label
+ testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label
+ testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label
+ testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label
+ testEQ NoDiscr _ = panic "mkMultiBranch NoDiscr"
+
-- None of these will be needed if there are no non-default alts
- (mkTestLT, mkTestEQ, init_lo, init_hi)
+ (init_lo, init_hi)
| null notd_ways
= panic "mkMultiBranch: awesome foursome"
| otherwise
- = case fst (head notd_ways) of {
- DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
- \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
- DiscrI minBound,
- DiscrI maxBound );
- DiscrW _ -> ( \(DiscrW i) fail_label -> TESTLT_W i fail_label,
- \(DiscrW i) fail_label -> TESTEQ_W i fail_label,
- DiscrW minBound,
- DiscrW maxBound );
- DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
- \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
- DiscrF minF,
- DiscrF maxF );
- DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
- \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
- DiscrD minD,
- DiscrD maxD );
- DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
- \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
- DiscrP algMinBound,
- DiscrP algMaxBound );
- NoDiscr -> panic "mkMultiBranch NoDiscr"
- }
+ = case fst (head notd_ways) of
+ DiscrI _ -> ( DiscrI minBound, DiscrI maxBound )
+ DiscrW _ -> ( DiscrW minBound, DiscrW maxBound )
+ DiscrF _ -> ( DiscrF minF, DiscrF maxF )
+ DiscrD _ -> ( DiscrD minD, DiscrD maxD )
+ DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )
+ NoDiscr -> panic "mkMultiBranch NoDiscr"
(algMinBound, algMaxBound)
= case maybe_ncons of
newUnique :: BcM Unique
newUnique = BcM $
- \st -> case splitUniqSupply (uniqSupply st) of
- (us1, us2) -> let newState = st { uniqSupply = us2 }
- in return (newState, uniqFromSupply us1)
+ \st -> case takeUniqFromSupply (uniqSupply st) of
+ (uniq, us) -> let newState = st { uniqSupply = us }
+ in return (newState, uniq)
newId :: Type -> BcM Id
newId ty = do