import Type
import DataCon
import TyCon
--- import Type
import Util
--- import DataCon
-import Var
import VarSet
import TysPrim
import DynFlags
{-
| trace (showSDoc (
(char ' '
- $$ (ppr.filter (not.isTyCoVar).varSetElems.fst) rhs
+ $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
$$ pprCoreExpr (deAnnotate rhs)
$$ char ' '
))) False
| 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)
rhs_code <- schemeE (d_alts+size) s p' rhs
return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code)
where
- real_bndrs = filter (not.isTyCoVar) bndrs
+ real_bndrs = filterOut isTyVar bndrs
my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
my_discr (DataAlt dc, _, _)
-> [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)
| Just e' <- bcView e
= pushAtom d p e'
+pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things,
+ = return (nilOL, 0) -- treated just like a variable VoidArg
+
pushAtom d p (AnnVar v)
| idCgRep v == VoidArg
= return (nilOL, 0)
-- Get the addr on the stack, untaggedly
return (unitOL (PUSH_UBX (Right addr) 1), 1)
-pushAtom d p (AnnCast e _)
- = pushAtom d p (snd e)
-
pushAtom _ _ expr
= pprPanic "ByteCodeGen.pushAtom"
(pprCoreExpr (deAnnotate (undefined, expr)))
= 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
-- whereas value lambdas cannot; that is why they are nuked here
bcView (AnnNote _ (_,e)) = Just e
bcView (AnnCast (_,e) _) = Just e
-bcView (AnnLam v (_,e)) | isTyCoVar v = Just e
+bcView (AnnLam v (_,e)) | isTyVar v = Just e
bcView (AnnApp (_,e) (_, AnnType _)) = Just e
bcView _ = Nothing
isVoidArgAtom :: AnnExpr' Var ann -> Bool
isVoidArgAtom e | Just e' <- bcView e = isVoidArgAtom e'
isVoidArgAtom (AnnVar v) = typePrimRep (idType v) == VoidRep
+isVoidArgAtom (AnnCoercion {}) = True
isVoidArgAtom _ = False
atomPrimRep :: AnnExpr' Id ann -> PrimRep
atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
atomPrimRep (AnnVar v) = typePrimRep (idType v)
atomPrimRep (AnnLit l) = typePrimRep (literalType l)
+atomPrimRep (AnnCoercion {}) = VoidRep
atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other)))
atomRep :: AnnExpr' Id ann -> CgRep
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
projects / ghc-hetmet.git / blobdiff