diff options
Diffstat (limited to 'compiler/prelude/PrelRules.hs')
| -rw-r--r-- | compiler/prelude/PrelRules.hs | 50 |
1 files changed, 22 insertions, 28 deletions
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs index 68140f73f3..3e9d7ae35a 100644 --- a/compiler/prelude/PrelRules.hs +++ b/compiler/prelude/PrelRules.hs @@ -35,7 +35,6 @@ import DataCon ( dataConTag, dataConTyCon, dataConWorkId ) import CoreUtils ( cheapEqExpr, exprIsHNF ) import CoreUnfold ( exprIsConApp_maybe ) import Type -import TypeRep import OccName ( occNameFS ) import PrelNames import Maybes ( orElse ) @@ -936,10 +935,9 @@ dataToTagRule = a `mplus` b -- seq# :: forall a s . a -> State# s -> (# State# s, a #) seqRule :: RuleM CoreExpr seqRule = do - [ty_a, Type ty_s, a, s] <- getArgs + [Type ty_a, Type ty_s, a, s] <- getArgs guard $ exprIsHNF a - return $ mkConApp (tupleDataCon Unboxed 2) - [Type (mkStatePrimTy ty_s), ty_a, s, a] + return $ mkCoreUbxTup [mkStatePrimTy ty_s, ty_a] [s, a] -- spark# :: forall a s . a -> State# s -> (# State# s, a #) sparkRule :: RuleM CoreExpr @@ -1178,7 +1176,7 @@ match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ] , Just dictTc <- tyConAppTyCon_maybe dictTy , Just (_,_,co) <- unwrapNewTyCon_maybe dictTc = Just - $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a])) + $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] [])) `App` y match_magicDict _ = Nothing @@ -1195,8 +1193,8 @@ match_IntToInteger = match_IntToInteger_unop id match_WordToInteger :: RuleFun match_WordToInteger _ id_unf id [xl] | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl - = case idType id of - FunTy _ integerTy -> + = case splitFunTy_maybe (idType id) of + Just (_, integerTy) -> Just (Lit (LitInteger x integerTy)) _ -> panic "match_WordToInteger: Id has the wrong type" @@ -1205,8 +1203,8 @@ match_WordToInteger _ _ _ _ = Nothing match_Int64ToInteger :: RuleFun match_Int64ToInteger _ id_unf id [xl] | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl - = case idType id of - FunTy _ integerTy -> + = case splitFunTy_maybe (idType id) of + Just (_, integerTy) -> Just (Lit (LitInteger x integerTy)) _ -> panic "match_Int64ToInteger: Id has the wrong type" @@ -1215,8 +1213,8 @@ match_Int64ToInteger _ _ _ _ = Nothing match_Word64ToInteger :: RuleFun match_Word64ToInteger _ id_unf id [xl] | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl - = case idType id of - FunTy _ integerTy -> + = case splitFunTy_maybe (idType id) of + Just (_, integerTy) -> Just (Lit (LitInteger x integerTy)) _ -> panic "match_Word64ToInteger: Id has the wrong type" @@ -1256,8 +1254,8 @@ warning in this case. match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun match_IntToInteger_unop unop _ id_unf fn [xl] | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl - = case idType fn of - FunTy _ integerTy -> + = case splitFunTy_maybe (idType fn) of + Just (_, integerTy) -> Just (Lit (LitInteger (unop x) integerTy)) _ -> panic "match_IntToInteger_unop: Id has the wrong type" @@ -1278,11 +1276,7 @@ match_Integer_divop_both divop _ id_unf _ [xl,yl] , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl , y /= 0 , (r,s) <- x `divop` y - = Just $ mkConApp (tupleDataCon Unboxed 2) - [Type t, - Type t, - Lit (LitInteger r t), - Lit (LitInteger s t)] + = Just $ mkCoreUbxTup [t,t] [Lit (LitInteger r t), Lit (LitInteger s t)] match_Integer_divop_both _ _ _ _ _ = Nothing -- This helper is used for the quot and rem functions @@ -1350,17 +1344,17 @@ match_rationalTo _ _ _ _ _ = Nothing match_decodeDouble :: RuleFun match_decodeDouble _ id_unf fn [xl] | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl - = case idType fn of - FunTy _ (TyConApp _ [integerTy, intHashTy]) -> - case decodeFloat (fromRational x :: Double) of - (y, z) -> - Just $ mkConApp (tupleDataCon Unboxed 2) - [Type integerTy, - Type intHashTy, - Lit (LitInteger y integerTy), - Lit (MachInt (toInteger z))] + = case splitFunTy_maybe (idType fn) of + Just (_, res) + | Just [_lev1, _lev2, integerTy, intHashTy] <- tyConAppArgs_maybe res + -> case decodeFloat (fromRational x :: Double) of + (y, z) -> + Just $ mkCoreUbxTup [integerTy, intHashTy] + [Lit (LitInteger y integerTy), + Lit (MachInt (toInteger z))] _ -> - panic "match_decodeDouble: Id has the wrong type" + pprPanic "match_decodeDouble: Id has the wrong type" + (ppr fn <+> dcolon <+> ppr (idType fn)) match_decodeDouble _ _ _ _ = Nothing match_XToIntegerToX :: Name -> RuleFun |