[commit: ghc] master: Add some more Integer rules; fixes #6111 (c7a8941)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/c7a8941b04541789e60950bb126902effae0ccab

>---------------------------------------------------------------

commit c7a8941b04541789e60950bb126902effae0ccab
Author: Ian Lynagh <igloo at earth.li>
Date:   Wed Jun 27 21:49:57 2012 +0100

    Add some more Integer rules; fixes #6111

>---------------------------------------------------------------

 compiler/basicTypes/Id.lhs        |    2 +-
 compiler/basicTypes/IdInfo.lhs    |    2 +-
 compiler/basicTypes/MkId.lhs-boot |    3 +++
 compiler/prelude/PrelRules.lhs    |   37 ++++++++++++++++++++++++++++++++++++-
 compiler/prelude/PrimOp.lhs-boot  |    7 +++++++
 5 files changed, 48 insertions(+), 3 deletions(-)

diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs
index e6e221b..b3011aa 100644
--- a/compiler/basicTypes/Id.lhs
+++ b/compiler/basicTypes/Id.lhs
@@ -118,7 +118,7 @@ import Demand
 import Name
 import Module
 import Class
-import PrimOp
+import {-# SOURCE #-} PrimOp (PrimOp)
 import ForeignCall
 import Maybes
 import SrcLoc
diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs
index 3f5eaa4..8a52ce1 100644
--- a/compiler/basicTypes/IdInfo.lhs
+++ b/compiler/basicTypes/IdInfo.lhs
@@ -75,7 +75,7 @@ module IdInfo (
 import CoreSyn
 
 import Class
-import PrimOp
+import {-# SOURCE #-} PrimOp (PrimOp)
 import Name
 import VarSet
 import BasicTypes
diff --git a/compiler/basicTypes/MkId.lhs-boot b/compiler/basicTypes/MkId.lhs-boot
index 4f9615a..7891e65 100644
--- a/compiler/basicTypes/MkId.lhs-boot
+++ b/compiler/basicTypes/MkId.lhs-boot
@@ -2,8 +2,11 @@
 module MkId where
 import Name( Name )
 import DataCon( DataCon, DataConIds )
+import {-# SOURCE #-} PrimOp( PrimOp )
+import Id( Id )
 
 mkDataConIds :: Name -> Name -> DataCon -> DataConIds
+mkPrimOpId :: PrimOp -> Id
 \end{code}
 
 
diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index 8bc070f..dab34fc 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -18,6 +18,8 @@ module PrelRules ( primOpRules, builtinRules ) where
 
 #include "HsVersions.h"
 
+import {-# SOURCE #-} MkId ( mkPrimOpId )
+
 import CoreSyn
 import MkCore
 import Id
@@ -659,7 +661,15 @@ builtinIntegerRules =
   rule_binop          "xorInteger"          xorIntegerName          xor,
   rule_unop           "complementInteger"   complementIntegerName   complement,
   rule_Int_binop      "shiftLInteger"       shiftLIntegerName       shiftL,
-  rule_Int_binop      "shiftRInteger"       shiftRIntegerName       shiftR]
+  rule_Int_binop      "shiftRInteger"       shiftRIntegerName       shiftR,
+  -- These rules below don't actually have to be built in, but if we
+  -- put them in the Haskell source then we'd have to duplicate them
+  -- between all Integer implementations
+  rule_smallIntegerToInt "smallIntegerToInt" integerToIntName,
+  rule_smallIntegerTo "smallIntegerToWord"   integerToWordName     Int2WordOp,
+  rule_smallIntegerTo "smallIntegerToFloat"  floatFromIntegerName  Int2FloatOp,
+  rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp
+  ]
     where rule_convert str name convert
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
                            ru_try = match_Integer_convert convert }
@@ -702,6 +712,12 @@ builtinIntegerRules =
           rule_decodeDouble str name
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
                            ru_try = match_decodeDouble }
+          rule_smallIntegerToInt str name
+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
+                           ru_try = match_smallIntegerToInt }
+          rule_smallIntegerTo str name primOp
+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
+                           ru_try = match_smallIntegerTo primOp }
 
 ---------------------------------------------------
 -- The rule is this:
@@ -946,4 +962,23 @@ match_decodeDouble fn id_unf [xl]
     _ ->
         panic "match_decodeDouble: Id has the wrong type"
 match_decodeDouble _ _ _ = Nothing
+
+match_smallIntegerToInt :: Id
+                        -> IdUnfoldingFun
+                        -> [Expr CoreBndr]
+                        -> Maybe (Expr CoreBndr)
+match_smallIntegerToInt _ _ [App (Var x) y]
+  | idName x == smallIntegerName
+  = Just y
+match_smallIntegerToInt _ _ _ = Nothing
+
+match_smallIntegerTo :: PrimOp
+                     -> Id
+                     -> IdUnfoldingFun
+                     -> [Expr CoreBndr]
+                     -> Maybe (Expr CoreBndr)
+match_smallIntegerTo primOp _ _ [App (Var x) y]
+  | idName x == smallIntegerName
+  = Just $ App (Var (mkPrimOpId primOp)) y
+match_smallIntegerTo _ _ _ _ = Nothing
 \end{code}
diff --git a/compiler/prelude/PrimOp.lhs-boot b/compiler/prelude/PrimOp.lhs-boot
new file mode 100644
index 0000000..5d003f2
--- /dev/null
+++ b/compiler/prelude/PrimOp.lhs-boot
@@ -0,0 +1,7 @@
+
+\begin{code}
+module PrimOp where
+
+data PrimOp
+\end{code}
+