[project @ 2001-03-26 16:51:26 by simonmar]

[ghc-hetmet.git] / ghc / compiler / prelude / PrelRules.lhs

diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs
index 0b54318..8b3f2d9 100644 (file)
--- a/ghc/compiler/prelude/PrelRules.lhs
+++ b/ghc/compiler/prelude/PrelRules.lhs
@@ -19,25 +19,24 @@ module PrelRules ( primOpRule, builtinRules ) where
 import CoreSyn
 import Id              ( mkWildId )
 import Literal         ( Literal(..), isLitLitLit, mkMachInt, mkMachWord
-                       , inIntRange, inWordRange, literalType
+                       , literalType
                        , word2IntLit, int2WordLit, char2IntLit, int2CharLit
                        , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
                        , addr2IntLit, int2AddrLit, float2DoubleLit, double2FloatLit
                        )
-import RdrName         ( RdrName )
 import PrimOp          ( PrimOp(..), primOpOcc )
 import TysWiredIn      ( trueDataConId, falseDataConId )
 import TyCon           ( tyConDataConsIfAvailable, isEnumerationTyCon, isNewTyCon )
 import DataCon         ( dataConTag, dataConTyCon, dataConId, fIRST_TAG )
 import CoreUtils       ( exprIsValue, cheapEqExpr, exprIsConApp_maybe )
-import Type            ( splitTyConApp_maybe )
+import Type            ( tyConAppTyCon )
 import OccName         ( occNameUserString)
-import PrelNames       ( unpackCStringFoldr_RDR )
-import Unique          ( unpackCStringFoldrIdKey, hasKey )
+import PrelNames       ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey )
+import Name            ( Name )
 import Bits            ( Bits(..) )
 import Word            ( Word64 )
 import Outputable
-import CmdLineOpts      ( opt_SimplStrictFP )
+import CmdLineOpts      ( opt_SimplExcessPrecision )
 \end{code}
 
 
@@ -286,9 +285,7 @@ intResult name result
 type RuleFun = [CoreExpr] -> Maybe (RuleName, CoreExpr)
 
 or_rule :: RuleFun -> RuleFun -> RuleFun
-or_rule r1 r2 args = case r1 args of
-                  Just stuff -> Just stuff
-                  Nothing    -> r2 args
+or_rule r1 r2 args = maybe (r2 args) Just (r1 args) -- i.e.: r1 args `mplus` r2 args
 
 twoLits :: (Literal -> Literal -> Maybe (RuleName, CoreExpr)) -> RuleFun
 twoLits rule [Lit l1, Lit l2] = rule (convFloating l1) (convFloating l2)
@@ -298,13 +295,13 @@ oneLit :: (Literal -> Maybe (RuleName, CoreExpr)) -> RuleFun
 oneLit rule [Lit l1] = rule (convFloating l1)
 oneLit rule other    = Nothing
 
--- When we strictfp is requested, cut down the precision of the Rational value
--- to that of Float/Double. We confuse host architecture and target architecture
--- here, but it's convenient (and wrong :-).
+-- When excess precision is not requested, cut down the precision of the
+-- Rational value to that of Float/Double. We confuse host architecture
+-- and target architecture here, but it's convenient (and wrong :-).
 convFloating :: Literal -> Literal
-convFloating (MachFloat  f) | opt_SimplStrictFP =
+convFloating (MachFloat  f) | not opt_SimplExcessPrecision =
    MachFloat  (toRational ((fromRational f) :: Float ))
-convFloating (MachDouble d) | opt_SimplStrictFP =
+convFloating (MachDouble d) | not opt_SimplExcessPrecision =
    MachDouble (toRational ((fromRational d) :: Double))
 convFloating l = l
 
@@ -313,7 +310,6 @@ trueVal       = Var trueDataConId
 falseVal      = Var falseDataConId
 mkIntVal    i = Lit (mkMachInt  i)
 mkWordVal   w = Lit (mkMachWord w)
-mkCharVal   c = Lit (MachChar   c)
 mkFloatVal  f = Lit (convFloating (MachFloat  f))
 mkDoubleVal d = Lit (convFloating (MachDouble d))
 \end{code}
@@ -396,8 +392,8 @@ tagToEnumRule [Type ty, Lit (MachInt i)]
                     Just (SLIT("TagToEnum"), Var (dataConId dc))
   where 
     correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
-    tag = fromInteger i
-    (Just (tycon,_)) = splitTyConApp_maybe ty
+    tag   = fromInteger i
+    tycon = tyConAppTyCon ty
 
 tagToEnumRule other = Nothing
 \end{code}
@@ -426,14 +422,15 @@ dataToTagRule other = Nothing
 %************************************************************************
 
 \begin{code}
-builtinRules :: [(RdrName, CoreRule)]
+builtinRules :: [(Name, CoreRule)]
 -- Rules for non-primops that can't be expressed using a RULE pragma
 builtinRules
-  = [ (unpackCStringFoldr_RDR, BuiltinRule match_append_lit_str)
+  = [ (unpackCStringFoldrName, BuiltinRule match_append_lit_str)
     ]
 
 
--- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)  =  unpackFoldrCString# "foobaz" c n
+-- The rule is this:
+--     unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)  =  unpackFoldrCString# "foobaz" c n
 
 match_append_lit_str [Type ty1,
                      Lit (MachStr s1),