Comparison primops return Int# (Fixes #6135)
authorJan Stolarek <jan.stolarek@p.lodz.pl>
Wed, 3 Jul 2013 14:23:37 +0000 (15:23 +0100)
committerJan Stolarek <jan.stolarek@p.lodz.pl>
Wed, 14 Aug 2013 11:46:06 +0000 (12:46 +0100)
This patch modifies all comparison primops for Char#, Int#, Word#, Double#,
Float# and Addr# to return Int# instead of Bool. A value of 1# represents True
and 0# represents False. For a more detailed description of motivation for this
change, discussion of implementation details and benchmarking results please
visit the wiki page: http://hackage.haskell.org/trac/ghc/wiki/PrimBool

There's also some cleanup: whitespace fixes in files that were extensively edited
in this patch and constant folding rules for Integer div and mod operators (which
for some reason have been left out up till now).

12 files changed:
compiler/codeGen/StgCmmExpr.hs
compiler/codeGen/StgCmmPrim.hs
compiler/prelude/PrelNames.lhs
compiler/prelude/PrelRules.lhs
compiler/prelude/PrimOp.lhs
compiler/prelude/primops.txt.pp
compiler/typecheck/TcDeriv.lhs
compiler/typecheck/TcGenDeriv.lhs
docs/users_guide/7.8.1-notes.xml
libraries/primitive
utils/genprimopcode/Main.hs
utils/genprimopcode/Syntax.hs

index 3d60def..20b65ba 100644 (file)
@@ -141,9 +141,9 @@ cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd _ args body)
   = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body
 cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
   = cgLetNoEscapeClosure bndr local_cc cc [] (StgConApp con args)
-        -- For a constructor RHS we want to generate a single chunk of 
-        -- code which can be jumped to from many places, which will 
-        -- return the constructor. It's easy; just behave as if it 
+        -- For a constructor RHS we want to generate a single chunk of
+        -- code which can be jumped to from many places, which will
+        -- return the constructor. It's easy; just behave as if it
         -- was an StgRhsClosure with a ConApp inside!
 
 -------------------------
@@ -193,9 +193,9 @@ heapcheck will take their worst case into account.
 In favour of omitting !Q!, !R!:
 
  - *May* save a heap overflow test,
-   if ...P... allocates anything.  
+   if ...P... allocates anything.
 
- - We can use relative addressing from a single Hp to 
+ - We can use relative addressing from a single Hp to
    get at all the closures so allocated.
 
  - No need to save volatile vars etc across heap checks
@@ -203,7 +203,7 @@ In favour of omitting !Q!, !R!:
 
 Against omitting !Q!, !R!
 
-  - May put a heap-check into the inner loop.  Suppose 
+  - May put a heap-check into the inner loop.  Suppose
         the main loop is P -> R -> P -> R...
         Q is the loop exit, and only it does allocation.
     This only hurts us if P does no allocation.  If P allocates,
@@ -212,7 +212,7 @@ Against omitting !Q!, !R!
   - May do more allocation than reqd.  This sometimes bites us
     badly.  For example, nfib (ha!) allocates about 30\% more space if the
     worst-casing is done, because many many calls to nfib are leaf calls
-    which don't need to allocate anything. 
+    which don't need to allocate anything.
 
     We can un-allocate, but that costs an instruction
 
@@ -248,7 +248,7 @@ Hence: two basic plans for
 
         ...save current cost centre...
 
-        ...code for e, 
+        ...code for e,
            with sequel (SetLocals r)
 
         ...restore current cost centre...
@@ -338,8 +338,12 @@ So we add a special case to generate
 
 and later optimisations will further improve this.
 
-We should really change all these primops to return Int# instead, that
-would make this special case go away.
+Now that #6135 has been resolved it should be possible to remove that
+special case. The idea behind this special case and pre-6135 implementation
+of Bool-returning primops was that tagToEnum# was added implicitly in the
+codegen and then optimized away. Now the call to tagToEnum# is explicit
+in the source code, which allows to optimize it away at the earlier stages
+of compilation (i.e. at the Core level).
 -}
 
 
@@ -498,7 +502,7 @@ cgAlts gc_plan bndr (PrimAlt _) alts
                 -- PrimAlts always have a DEFAULT case
                 -- and it always comes first
 
-              tagged_cmms' = [(lit,code) 
+              tagged_cmms' = [(lit,code)
                              | (LitAlt lit, code) <- tagged_cmms]
         ; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt
         ; return AssignedDirectly }
@@ -637,7 +641,7 @@ cgLneJump blk_id lne_regs args  -- Join point; discard sequel
         ; emitMultiAssign lne_regs cmm_args
         ; emit (mkBranch blk_id)
         ; return AssignedDirectly }
-    
+
 cgTailCall :: Id -> CgIdInfo -> [StgArg] -> FCode ReturnKind
 cgTailCall fun_id fun_info args = do
     dflags <- getDynFlags
@@ -645,7 +649,7 @@ cgTailCall fun_id fun_info args = do
 
             -- A value in WHNF, so we can just return it.
         ReturnIt -> emitReturn [fun]    -- ToDo: does ReturnIt guarantee tagged?
-    
+
         EnterIt -> ASSERT( null args )  -- Discarding arguments
                    emitEnter fun
 
@@ -653,7 +657,7 @@ cgTailCall fun_id fun_info args = do
                 { tickySlowCall lf_info args
                 ; emitComment $ mkFastString "slowCall"
                 ; slowCall fun args }
-    
+
         -- A direct function call (possibly with some left-over arguments)
         DirectEntry lbl arity -> do
                 { tickyDirectCall arity args
index 7ce329a..2c044fa 100644 (file)
@@ -107,15 +107,6 @@ cgOpApp (StgPrimOp primop) args res_ty
        cgPrimOp regs primop args
        emitReturn (map (CmmReg . CmmLocal) regs)
 
-  | ReturnsAlg tycon <- result_info
-  , isEnumerationTyCon tycon
-        -- c.f. cgExpr (...TagToEnumOp...)
-  = do dflags <- getDynFlags
-       tag_reg <- newTemp (bWord dflags)
-       cgPrimOp [tag_reg] primop args
-       emitReturn [tagToClosure dflags tycon
-                                (CmmReg (CmmLocal tag_reg))]
-
   | otherwise = panic "cgPrimop"
   where
      result_info = getPrimOpResultInfo primop
index 8452092..3e5384b 100644 (file)
@@ -233,13 +233,13 @@ basicKnownKeyNames
         -- Strings and lists
         unpackCStringName,
         unpackCStringFoldrName, unpackCStringUtf8Name,
-        
+
         -- Overloaded lists
         isListClassName,
         fromListName,
         fromListNName,
         toListName,
-        
+
         -- List operations
         concatName, filterName, mapName,
         zipName, foldrName, buildName, augmentName, appendName,
@@ -265,11 +265,11 @@ basicKnownKeyNames
         plusIntegerName, timesIntegerName, smallIntegerName,
         wordToIntegerName,
         integerToWordName, integerToIntName, minusIntegerName,
-        negateIntegerName, eqIntegerName, neqIntegerName,
+        negateIntegerName, eqIntegerPrimName, neqIntegerPrimName,
         absIntegerName, signumIntegerName,
-        leIntegerName, gtIntegerName, ltIntegerName, geIntegerName,
+        leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName,
         compareIntegerName, quotRemIntegerName, divModIntegerName,
-        quotIntegerName, remIntegerName,
+        quotIntegerName, remIntegerName, divIntegerName, modIntegerName,
         floatFromIntegerName, doubleFromIntegerName,
         encodeFloatIntegerName, encodeDoubleIntegerName,
         decodeDoubleIntegerName,
@@ -350,8 +350,7 @@ genericTyConNames = [
 pRELUDE :: Module
 pRELUDE         = mkBaseModule_ pRELUDE_NAME
 
-gHC_PRIM, gHC_TYPES, gHC_GENERICS,
-    gHC_MAGIC,
+gHC_PRIM, gHC_PRIMWRAPPERS, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
     gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING,
     gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_LIST,
     gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID,
@@ -364,6 +363,7 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS,
     cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_IP :: Module
 
 gHC_PRIM        = mkPrimModule (fsLit "GHC.Prim")   -- Primitive types and values
+gHC_PRIMWRAPPERS = mkPrimModule (fsLit "GHC.PrimWrappers")
 gHC_TYPES       = mkPrimModule (fsLit "GHC.Types")
 gHC_MAGIC       = mkPrimModule (fsLit "GHC.Magic")
 gHC_CSTRING     = mkPrimModule (fsLit "GHC.CString")
@@ -558,9 +558,8 @@ unpackCString_RDR       = nameRdrName unpackCStringName
 unpackCStringFoldr_RDR  = nameRdrName unpackCStringFoldrName
 unpackCStringUtf8_RDR   = nameRdrName unpackCStringUtf8Name
 
-newStablePtr_RDR, wordDataCon_RDR :: RdrName
+newStablePtr_RDR :: RdrName
 newStablePtr_RDR        = nameRdrName newStablePtrName
-wordDataCon_RDR         = dataQual_RDR gHC_TYPES (fsLit "W#")
 
 bindIO_RDR, returnIO_RDR :: RdrName
 bindIO_RDR              = nameRdrName bindIOName
@@ -882,11 +881,11 @@ integerTyConName, mkIntegerName,
     plusIntegerName, timesIntegerName, smallIntegerName,
     wordToIntegerName,
     integerToWordName, integerToIntName, minusIntegerName,
-    negateIntegerName, eqIntegerName, neqIntegerName,
+    negateIntegerName, eqIntegerPrimName, neqIntegerPrimName,
     absIntegerName, signumIntegerName,
-    leIntegerName, gtIntegerName, ltIntegerName, geIntegerName,
+    leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName,
     compareIntegerName, quotRemIntegerName, divModIntegerName,
-    quotIntegerName, remIntegerName,
+    quotIntegerName, remIntegerName, divIntegerName, modIntegerName,
     floatFromIntegerName, doubleFromIntegerName,
     encodeFloatIntegerName, encodeDoubleIntegerName,
     decodeDoubleIntegerName,
@@ -907,19 +906,21 @@ integerToWordName     = varQual gHC_INTEGER_TYPE (fsLit "integerToWord")     int
 integerToIntName      = varQual gHC_INTEGER_TYPE (fsLit "integerToInt")      integerToIntIdKey
 minusIntegerName      = varQual gHC_INTEGER_TYPE (fsLit "minusInteger")      minusIntegerIdKey
 negateIntegerName     = varQual gHC_INTEGER_TYPE (fsLit "negateInteger")     negateIntegerIdKey
-eqIntegerName         = varQual gHC_INTEGER_TYPE (fsLit "eqInteger")         eqIntegerIdKey
-neqIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "neqInteger")        neqIntegerIdKey
+eqIntegerPrimName     = varQual gHC_INTEGER_TYPE (fsLit "eqInteger#")        eqIntegerPrimIdKey
+neqIntegerPrimName    = varQual gHC_INTEGER_TYPE (fsLit "neqInteger#")       neqIntegerPrimIdKey
 absIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "absInteger")        absIntegerIdKey
 signumIntegerName     = varQual gHC_INTEGER_TYPE (fsLit "signumInteger")     signumIntegerIdKey
-leIntegerName         = varQual gHC_INTEGER_TYPE (fsLit "leInteger")         leIntegerIdKey
-gtIntegerName         = varQual gHC_INTEGER_TYPE (fsLit "gtInteger")         gtIntegerIdKey
-ltIntegerName         = varQual gHC_INTEGER_TYPE (fsLit "ltInteger")         ltIntegerIdKey
-geIntegerName         = varQual gHC_INTEGER_TYPE (fsLit "geInteger")         geIntegerIdKey
+leIntegerPrimName     = varQual gHC_INTEGER_TYPE (fsLit "leInteger#")        leIntegerPrimIdKey
+gtIntegerPrimName     = varQual gHC_INTEGER_TYPE (fsLit "gtInteger#")        gtIntegerPrimIdKey
+ltIntegerPrimName     = varQual gHC_INTEGER_TYPE (fsLit "ltInteger#")        ltIntegerPrimIdKey
+geIntegerPrimName     = varQual gHC_INTEGER_TYPE (fsLit "geInteger#")        geIntegerPrimIdKey
 compareIntegerName    = varQual gHC_INTEGER_TYPE (fsLit "compareInteger")    compareIntegerIdKey
 quotRemIntegerName    = varQual gHC_INTEGER_TYPE (fsLit "quotRemInteger")    quotRemIntegerIdKey
 divModIntegerName     = varQual gHC_INTEGER_TYPE (fsLit "divModInteger")     divModIntegerIdKey
 quotIntegerName       = varQual gHC_INTEGER_TYPE (fsLit "quotInteger")       quotIntegerIdKey
 remIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "remInteger")        remIntegerIdKey
+divIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "divInteger")        divIntegerIdKey
+modIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "modInteger")        modIntegerIdKey
 floatFromIntegerName  = varQual gHC_INTEGER_TYPE (fsLit "floatFromInteger")      floatFromIntegerIdKey
 doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromInteger")     doubleFromIntegerIdKey
 encodeFloatIntegerName  = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatInteger")  encodeFloatIntegerIdKey
@@ -1593,10 +1594,10 @@ mkIntegerIdKey, smallIntegerIdKey, wordToIntegerIdKey,
     word64ToIntegerIdKey, int64ToIntegerIdKey,
     plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey,
     negateIntegerIdKey,
-    eqIntegerIdKey, neqIntegerIdKey, absIntegerIdKey, signumIntegerIdKey,
-    leIntegerIdKey, gtIntegerIdKey, ltIntegerIdKey, geIntegerIdKey,
+    eqIntegerPrimIdKey, neqIntegerPrimIdKey, absIntegerIdKey, signumIntegerIdKey,
+    leIntegerPrimIdKey, gtIntegerPrimIdKey, ltIntegerPrimIdKey, geIntegerPrimIdKey,
     compareIntegerIdKey, quotRemIntegerIdKey, divModIntegerIdKey,
-    quotIntegerIdKey, remIntegerIdKey,
+    quotIntegerIdKey, remIntegerIdKey, divIntegerIdKey, modIntegerIdKey,
     floatFromIntegerIdKey, doubleFromIntegerIdKey,
     encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey,
     decodeDoubleIntegerIdKey,
@@ -1613,44 +1614,46 @@ plusIntegerIdKey              = mkPreludeMiscIdUnique 66
 timesIntegerIdKey             = mkPreludeMiscIdUnique 67
 minusIntegerIdKey             = mkPreludeMiscIdUnique 68
 negateIntegerIdKey            = mkPreludeMiscIdUnique 69
-eqIntegerIdKey                = mkPreludeMiscIdUnique 70
-neqIntegerIdKey               = mkPreludeMiscIdUnique 71
+eqIntegerPrimIdKey            = mkPreludeMiscIdUnique 70
+neqIntegerPrimIdKey           = mkPreludeMiscIdUnique 71
 absIntegerIdKey               = mkPreludeMiscIdUnique 72
 signumIntegerIdKey            = mkPreludeMiscIdUnique 73
-leIntegerIdKey                = mkPreludeMiscIdUnique 74
-gtIntegerIdKey                = mkPreludeMiscIdUnique 75
-ltIntegerIdKey                = mkPreludeMiscIdUnique 76
-geIntegerIdKey                = mkPreludeMiscIdUnique 77
+leIntegerPrimIdKey            = mkPreludeMiscIdUnique 74
+gtIntegerPrimIdKey            = mkPreludeMiscIdUnique 75
+ltIntegerPrimIdKey            = mkPreludeMiscIdUnique 76
+geIntegerPrimIdKey            = mkPreludeMiscIdUnique 77
 compareIntegerIdKey           = mkPreludeMiscIdUnique 78
-quotRemIntegerIdKey           = mkPreludeMiscIdUnique 79
-divModIntegerIdKey            = mkPreludeMiscIdUnique 80
-quotIntegerIdKey              = mkPreludeMiscIdUnique 81
-remIntegerIdKey               = mkPreludeMiscIdUnique 82
-floatFromIntegerIdKey         = mkPreludeMiscIdUnique 83
-doubleFromIntegerIdKey        = mkPreludeMiscIdUnique 84
-encodeFloatIntegerIdKey       = mkPreludeMiscIdUnique 85
-encodeDoubleIntegerIdKey      = mkPreludeMiscIdUnique 86
-gcdIntegerIdKey               = mkPreludeMiscIdUnique 87
-lcmIntegerIdKey               = mkPreludeMiscIdUnique 88
-andIntegerIdKey               = mkPreludeMiscIdUnique 89
-orIntegerIdKey                = mkPreludeMiscIdUnique 90
-xorIntegerIdKey               = mkPreludeMiscIdUnique 91
-complementIntegerIdKey        = mkPreludeMiscIdUnique 92
-shiftLIntegerIdKey            = mkPreludeMiscIdUnique 93
-shiftRIntegerIdKey            = mkPreludeMiscIdUnique 94
-wordToIntegerIdKey            = mkPreludeMiscIdUnique 95
-word64ToIntegerIdKey          = mkPreludeMiscIdUnique 96
-int64ToIntegerIdKey           = mkPreludeMiscIdUnique 97
-decodeDoubleIntegerIdKey      = mkPreludeMiscIdUnique 98
+quotIntegerIdKey              = mkPreludeMiscIdUnique 79
+remIntegerIdKey               = mkPreludeMiscIdUnique 80
+divIntegerIdKey               = mkPreludeMiscIdUnique 81
+modIntegerIdKey               = mkPreludeMiscIdUnique 82
+divModIntegerIdKey            = mkPreludeMiscIdUnique 83
+quotRemIntegerIdKey           = mkPreludeMiscIdUnique 84
+floatFromIntegerIdKey         = mkPreludeMiscIdUnique 85
+doubleFromIntegerIdKey        = mkPreludeMiscIdUnique 86
+encodeFloatIntegerIdKey       = mkPreludeMiscIdUnique 87
+encodeDoubleIntegerIdKey      = mkPreludeMiscIdUnique 88
+gcdIntegerIdKey               = mkPreludeMiscIdUnique 89
+lcmIntegerIdKey               = mkPreludeMiscIdUnique 90
+andIntegerIdKey               = mkPreludeMiscIdUnique 91
+orIntegerIdKey                = mkPreludeMiscIdUnique 92
+xorIntegerIdKey               = mkPreludeMiscIdUnique 93
+complementIntegerIdKey        = mkPreludeMiscIdUnique 94
+shiftLIntegerIdKey            = mkPreludeMiscIdUnique 95
+shiftRIntegerIdKey            = mkPreludeMiscIdUnique 96
+wordToIntegerIdKey            = mkPreludeMiscIdUnique 97
+word64ToIntegerIdKey          = mkPreludeMiscIdUnique 98
+int64ToIntegerIdKey           = mkPreludeMiscIdUnique 99
+decodeDoubleIntegerIdKey      = mkPreludeMiscIdUnique 100
 
 rootMainKey, runMainKey :: Unique
-rootMainKey                   = mkPreludeMiscIdUnique 100
-runMainKey                    = mkPreludeMiscIdUnique 101
+rootMainKey                   = mkPreludeMiscIdUnique 101
+runMainKey                    = mkPreludeMiscIdUnique 102
 
 thenIOIdKey, lazyIdKey, assertErrorIdKey :: Unique
-thenIOIdKey                   = mkPreludeMiscIdUnique 102
-lazyIdKey                     = mkPreludeMiscIdUnique 103
-assertErrorIdKey              = mkPreludeMiscIdUnique 104
+thenIOIdKey                   = mkPreludeMiscIdUnique 103
+lazyIdKey                     = mkPreludeMiscIdUnique 104
+assertErrorIdKey              = mkPreludeMiscIdUnique 105
 
 breakpointIdKey, breakpointCondIdKey, breakpointAutoIdKey,
     breakpointJumpIdKey, breakpointCondJumpIdKey,
index 96e39fe..53a0aa8 100644 (file)
@@ -220,6 +220,7 @@ primOpRules nm DoubleNegOp   = mkPrimOpRule nm 1 [ unaryLit negOp
                                                  , inversePrimOp DoubleNegOp ]
 
 -- Relational operators
+
 primOpRules nm IntEqOp    = mkRelOpRule nm (==) [ litEq True ]
 primOpRules nm IntNeOp    = mkRelOpRule nm (/=) [ litEq False ]
 primOpRules nm CharEqOp   = mkRelOpRule nm (==) [ litEq True ]
@@ -235,19 +236,19 @@ primOpRules nm CharGeOp   = mkRelOpRule nm (>=) [ boundsCmp Ge ]
 primOpRules nm CharLeOp   = mkRelOpRule nm (<=) [ boundsCmp Le ]
 primOpRules nm CharLtOp   = mkRelOpRule nm (<)  [ boundsCmp Lt ]
 
-primOpRules nm FloatGtOp  = mkRelOpRule nm (>)  []
-primOpRules nm FloatGeOp  = mkRelOpRule nm (>=) []
-primOpRules nm FloatLeOp  = mkRelOpRule nm (<=) []
-primOpRules nm FloatLtOp  = mkRelOpRule nm (<)  []
-primOpRules nm FloatEqOp  = mkRelOpRule nm (==) [ litEq True ]
-primOpRules nm FloatNeOp  = mkRelOpRule nm (/=) [ litEq False ]
+primOpRules nm FloatGtOp  = mkFloatingRelOpRule nm (>)  []
+primOpRules nm FloatGeOp  = mkFloatingRelOpRule nm (>=) []
+primOpRules nm FloatLeOp  = mkFloatingRelOpRule nm (<=) []
+primOpRules nm FloatLtOp  = mkFloatingRelOpRule nm (<)  []
+primOpRules nm FloatEqOp  = mkFloatingRelOpRule nm (==) [ litEq True ]
+primOpRules nm FloatNeOp  = mkFloatingRelOpRule nm (/=) [ litEq False ]
 
-primOpRules nm DoubleGtOp = mkRelOpRule nm (>)  []
-primOpRules nm DoubleGeOp = mkRelOpRule nm (>=) []
-primOpRules nm DoubleLeOp = mkRelOpRule nm (<=) []
-primOpRules nm DoubleLtOp = mkRelOpRule nm (<)  []
-primOpRules nm DoubleEqOp = mkRelOpRule nm (==) [ litEq True ]
-primOpRules nm DoubleNeOp = mkRelOpRule nm (/=) [ litEq False ]
+primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>)  []
+primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=) []
+primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=) []
+primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<)  []
+primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==) [ litEq True ]
+primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=) [ litEq False ]
 
 primOpRules nm WordGtOp   = mkRelOpRule nm (>)  [ boundsCmp Gt ]
 primOpRules nm WordGeOp   = mkRelOpRule nm (>=) [ boundsCmp Ge ]
@@ -282,14 +283,27 @@ mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
 mkRelOpRule nm cmp extra
   = mkPrimOpRule nm 2 $ rules ++ extra
   where
-    rules = [ binaryLit (\_ -> cmpOp cmp)
-            , equalArgs >>
+    rules = [ binaryCmpLit cmp
+            , do equalArgs
               -- x `cmp` x does not depend on x, so
               -- compute it for the arbitrary value 'True'
               -- and use that result
-              return (if cmp True True
-                        then trueVal
-                        else falseVal) ]
+                 dflags <- getDynFlags
+                 return (if cmp True True
+                         then trueValInt  dflags
+                         else falseValInt dflags) ]
+
+-- Note [Rules for floating-point comparisons]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- We need different rules for floating-point values because for floats
+-- it is not true that x = x. The special case when this does not occur
+-- are NaNs.
+
+mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
+                    -> [RuleM CoreExpr] -> Maybe CoreRule
+mkFloatingRelOpRule nm cmp extra -- See Note [Rules for floating-point comparisons]
+  = mkPrimOpRule nm 2 $ binaryCmpLit cmp : extra
 
 -- common constants
 zeroi, onei, zerow, onew :: DynFlags -> Literal
@@ -306,12 +320,12 @@ zerod = mkMachDouble 0.0
 oned  = mkMachDouble 1.0
 twod  = mkMachDouble 2.0
 
-cmpOp :: (forall a . Ord a => a -> a -> Bool)
+cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool)
       -> Literal -> Literal -> Maybe CoreExpr
-cmpOp cmp = go
+cmpOp dflags cmp = go
   where
-    done True  = Just trueVal
-    done False = Just falseVal
+    done True  = Just $ trueValInt  dflags
+    done False = Just $ falseValInt dflags
 
     -- These compares are at different types
     go (MachChar i1)   (MachChar i2)   = done (i1 `cmp` i2)
@@ -408,19 +422,22 @@ litEq :: Bool  -- True <=> equality, False <=> inequality
       -> RuleM CoreExpr
 litEq is_eq = msum
   [ do [Lit lit, expr] <- getArgs
-       do_lit_eq lit expr
+       dflags <- getDynFlags
+       do_lit_eq dflags lit expr
   , do [expr, Lit lit] <- getArgs
-       do_lit_eq lit expr ]
+       dflags <- getDynFlags
+       do_lit_eq dflags lit expr ]
   where
-    do_lit_eq lit expr = do
+    do_lit_eq dflags lit expr = do
       guard (not (litIsLifted lit))
-      return (mkWildCase expr (literalType lit) boolTy
+      return (mkWildCase expr (literalType lit) intPrimTy
                     [(DEFAULT,    [], val_if_neq),
                      (LitAlt lit, [], val_if_eq)])
-    val_if_eq  | is_eq     = trueVal
-               | otherwise = falseVal
-    val_if_neq | is_eq     = falseVal
-               | otherwise = trueVal
+      where
+        val_if_eq  | is_eq     = trueValInt  dflags
+                   | otherwise = falseValInt dflags
+        val_if_neq | is_eq     = falseValInt dflags
+                   | otherwise = trueValInt  dflags
 
 
 -- | Check if there is comparison with minBound or maxBound, that is
@@ -435,14 +452,14 @@ boundsCmp op = do
 data Comparison = Gt | Ge | Lt | Le
 
 mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
-mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just falseVal
-mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just trueVal
-mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just trueVal
-mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just falseVal
-mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just trueVal
-mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just falseVal
-mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just falseVal
-mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just trueVal
+mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just $ falseValInt dflags
+mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just $ trueValInt  dflags
+mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just $ trueValInt  dflags
+mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just $ falseValInt dflags
+mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just $ trueValInt  dflags
+mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just $ falseValInt dflags
+mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just $ falseValInt dflags
+mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt  dflags
 mkRuleFn _ _ _ _                                       = Nothing
 
 isMinBound :: DynFlags -> Literal -> Bool
@@ -585,6 +602,11 @@ binaryLit op = do
   [Lit l1, Lit l2] <- getArgs
   liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2)
 
+binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr
+binaryCmpLit op = do
+  dflags <- getDynFlags
+  binaryLit (\_ -> cmpOp dflags op)
+
 leftIdentity :: Literal -> RuleM CoreExpr
 leftIdentity id_lit = leftIdentityDynFlags (const id_lit)
 
@@ -679,9 +701,23 @@ strengthReduction two_lit add_op = do -- Note [Strength reduction]
 -- x * 2.0 into x + x addition, because addition costs less than multiplication.
 -- See #7116
 
-trueVal, falseVal :: Expr CoreBndr
-trueVal       = Var trueDataConId
-falseVal      = Var falseDataConId
+-- Note [What's true and false]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- trueValInt and falseValInt represent true and false values returned by
+-- comparison primops for Char, Int, Word, Integer, Double, Float and Addr.
+-- True is represented as an unboxed 1# literal, while false is represented
+-- as 0# literal.
+-- We still need Bool data constructors (True and False) to use in a rule
+-- for constant folding of equal Strings
+
+trueValInt, falseValInt :: DynFlags -> Expr CoreBndr
+trueValInt  dflags = Lit $ onei  dflags -- see Note [What's true and false]
+falseValInt dflags = Lit $ zeroi dflags
+
+trueValBool, falseValBool :: Expr CoreBndr
+trueValBool   = Var trueDataConId -- see Note [What's true and false]
+falseValBool  = Var falseDataConId
 
 ltVal, eqVal, gtVal :: Expr CoreBndr
 ltVal = Var ltDataConId
@@ -837,7 +873,7 @@ builtinRules
                    ru_fn = unpackCStringFoldrName,
                    ru_nargs = 4, ru_try = \_ _ _ -> match_append_lit },
      BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
-                   ru_nargs = 2, ru_try = \_ _ _ -> match_eq_string },
+                   ru_nargs = 2, ru_try = \dflags _ _ -> match_eq_string dflags },
      BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
                    ru_nargs = 2, ru_try = \_ _ _ -> match_inline },
      BuiltinRule { ru_name = fsLit "MagicSingI", ru_fn = idName magicSingIId,
@@ -859,19 +895,15 @@ builtinIntegerRules =
   rule_binop          "minusInteger"        minusIntegerName        (-),
   rule_binop          "timesInteger"        timesIntegerName        (*),
   rule_unop           "negateInteger"       negateIntegerName       negate,
-  rule_binop_Bool     "eqInteger"           eqIntegerName           (==),
-  rule_binop_Bool     "neqInteger"          neqIntegerName          (/=),
+  rule_binop_Prim     "eqInteger#"          eqIntegerPrimName       (==),
+  rule_binop_Prim     "neqInteger#"         neqIntegerPrimName      (/=),
   rule_unop           "absInteger"          absIntegerName          abs,
   rule_unop           "signumInteger"       signumIntegerName       signum,
-  rule_binop_Bool     "leInteger"           leIntegerName           (<=),
-  rule_binop_Bool     "gtInteger"           gtIntegerName           (>),
-  rule_binop_Bool     "ltInteger"           ltIntegerName           (<),
-  rule_binop_Bool     "geInteger"           geIntegerName           (>=),
+  rule_binop_Prim     "leInteger#"          leIntegerPrimName       (<=),
+  rule_binop_Prim     "gtInteger#"          gtIntegerPrimName       (>),
+  rule_binop_Prim     "ltInteger#"          ltIntegerPrimName       (<),
+  rule_binop_Prim     "geInteger#"          geIntegerPrimName       (>=),
   rule_binop_Ordering "compareInteger"      compareIntegerName      compare,
-  rule_divop_both     "divModInteger"       divModIntegerName       divMod,
-  rule_divop_both     "quotRemInteger"      quotRemIntegerName      quotRem,
-  rule_divop_one      "quotInteger"         quotIntegerName         quot,
-  rule_divop_one      "remInteger"          remIntegerName          rem,
   rule_encodeFloat    "encodeFloatInteger"  encodeFloatIntegerName  mkFloatLitFloat,
   rule_convert        "floatFromInteger"    floatFromIntegerName    (\_ -> mkFloatLitFloat),
   rule_encodeFloat    "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,
@@ -887,6 +919,12 @@ builtinIntegerRules =
   rule_unop           "complementInteger"   complementIntegerName   complement,
   rule_Int_binop      "shiftLInteger"       shiftLIntegerName       shiftL,
   rule_Int_binop      "shiftRInteger"       shiftRIntegerName       shiftR,
+  rule_divop_one      "quotInteger"         quotIntegerName         quot,
+  rule_divop_one      "remInteger"          remIntegerName          rem,
+  rule_divop_one      "divInteger"          divIntegerName          div,
+  rule_divop_one      "modInteger"          modIntegerName          mod,
+  rule_divop_both     "divModInteger"       divModIntegerName       divMod,
+  rule_divop_both     "quotRemInteger"      quotRemIntegerName      quotRem,
   -- 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
@@ -928,9 +966,9 @@ builtinIntegerRules =
           rule_Int_binop str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
                            ru_try = match_Integer_Int_binop op }
-          rule_binop_Bool str name op
+          rule_binop_Prim str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
-                           ru_try = match_Integer_binop_Bool op }
+                           ru_try = match_Integer_binop_Prim op }
           rule_binop_Ordering str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
                            ru_try = match_Integer_binop_Ordering op }
@@ -978,14 +1016,14 @@ match_append_lit _ = Nothing
 -- The rule is this:
 --      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
 
-match_eq_string :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
-match_eq_string [Var unpk1 `App` Lit (MachStr s1),
-                   Var unpk2 `App` Lit (MachStr s2)]
+match_eq_string :: DynFlags -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
+match_eq_string [Var unpk1 `App` Lit (MachStr s1),
+                        Var unpk2 `App` Lit (MachStr s2)]
   | unpk1 `hasKey` unpackCStringIdKey,
     unpk2 `hasKey` unpackCStringIdKey
-  = Just (if s1 == s2 then trueVal else falseVal)
+  = Just (if s1 == s2 then trueValBool else falseValBool)
 
-match_eq_string _ = Nothing
+match_eq_string _ = Nothing
 
 
 ---------------------------------------------------
@@ -1107,7 +1145,7 @@ match_Integer_divop_both divop _ id_unf _ [xl,yl]
                      Lit (LitInteger s t)]
 match_Integer_divop_both _ _ _ _ _ = Nothing
 
--- This helper is used for the quotRem and divMod functions
+-- This helper is used for the quot and rem functions
 match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun
 match_Integer_divop_one divop _ id_unf _ [xl,yl]
   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
@@ -1123,12 +1161,12 @@ match_Integer_Int_binop binop _ id_unf _ [xl,yl]
   = Just (Lit (LitInteger (x `binop` fromIntegral y) i))
 match_Integer_Int_binop _ _ _ _ _ = Nothing
 
-match_Integer_binop_Bool :: (Integer -> Integer -> Bool) -> RuleFun
-match_Integer_binop_Bool binop _ id_unf _ [xl, yl]
+match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun
+match_Integer_binop_Prim binop dflags id_unf _ [xl, yl]
   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
-  = Just (if x `binop` y then trueVal else falseVal)
-match_Integer_binop_Bool _ _ _ _ _ = Nothing
+  = Just (if x `binop` y then trueValInt dflags else falseValInt dflags)
+match_Integer_binop_Prim _ _ _ _ _ = Nothing
 
 match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun
 match_Integer_binop_Ordering binop _ id_unf _ [xl, yl]
index 1aaca36..8b1970c 100644 (file)
@@ -118,9 +118,8 @@ data PrimOpInfo
                 Type
   | Monadic     OccName         -- string :: T -> T
                 Type
-  | Compare     OccName         -- string :: T -> T -> Bool
+  | Compare     OccName         -- string :: T -> T -> Int#
                 Type
-
   | GenPrimOp   OccName         -- string :: \/a1..an . T1 -> .. -> Tk -> T
                 [TyVar]
                 [Type]
@@ -513,10 +512,10 @@ primOpSig op
     arity = length arg_tys
     (tyvars, arg_tys, res_ty)
       = case (primOpInfo op) of
-        Monadic   _occ ty                    -> ([],     [ty],    ty    )
-        Dyadic    _occ ty                    -> ([],     [ty,ty], ty    )
-        Compare   _occ ty                    -> ([],     [ty,ty], boolTy)
-        GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty)
+        Monadic   _occ ty                    -> ([],     [ty],    ty       )
+        Dyadic    _occ ty                    -> ([],     [ty,ty], ty       )
+        Compare   _occ ty                    -> ([],     [ty,ty], intPrimTy)
+        GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty   )
 \end{code}
 
 \begin{code}
@@ -533,7 +532,7 @@ getPrimOpResultInfo op
   = case (primOpInfo op) of
       Dyadic  _ ty                        -> ReturnsPrim (typePrimRep ty)
       Monadic _ ty                        -> ReturnsPrim (typePrimRep ty)
-      Compare _ _                         -> ReturnsAlg boolTyCon
+      Compare _ _                         -> ReturnsPrim (tyConPrimRep intPrimTyCon)
       GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep tc)
                          | otherwise      -> ReturnsAlg tc
                          where
@@ -560,7 +559,7 @@ Utils:
 dyadic_fun_ty, monadic_fun_ty, compare_fun_ty :: Type -> Type
 dyadic_fun_ty  ty = mkFunTys [ty, ty] ty
 monadic_fun_ty ty = mkFunTy  ty ty
-compare_fun_ty ty = mkFunTys [ty, ty] boolTy
+compare_fun_ty ty = mkFunTys [ty, ty] intPrimTy
 \end{code}
 
 Output stuff:
index 0c325a6..5115624 100644 (file)
@@ -140,19 +140,19 @@ section "Char#"
 
 primtype Char#
 
-primop   CharGtOp  "gtChar#"   Compare   Char# -> Char# -> Bool
-primop   CharGeOp  "geChar#"   Compare   Char# -> Char# -> Bool
+primop   CharGtOp  "gtCharI#"   Compare   Char# -> Char# -> Int#
+primop   CharGeOp  "geCharI#"   Compare   Char# -> Char# -> Int#
 
-primop   CharEqOp  "eqChar#"   Compare
-   Char# -> Char# -> Bool
+primop   CharEqOp  "eqCharI#"   Compare
+   Char# -> Char# -> Int#
    with commutable = True
 
-primop   CharNeOp  "neChar#"   Compare
-   Char# -> Char# -> Bool
+primop   CharNeOp  "neCharI#"   Compare
+   Char# -> Char# -> Int#
    with commutable = True
 
-primop   CharLtOp  "ltChar#"   Compare   Char# -> Char# -> Bool
-primop   CharLeOp  "leChar#"   Compare   Char# -> Char# -> Bool
+primop   CharLtOp  "ltCharI#"   Compare   Char# -> Char# -> Int#
+primop   CharLeOp  "leCharI#"   Compare   Char# -> Char# -> Int#
 
 primop   OrdOp   "ord#"  GenPrimOp   Char# -> Int#
    with code_size = 0
@@ -239,26 +239,26 @@ primop   IntSubCOp   "subIntC#"    GenPrimOp   Int# -> Int# -> (# Int#, Int# #)
           second member is 0 iff no overflow occured.}
    with code_size = 2
 
-primop   IntGtOp  ">#"   Compare   Int# -> Int# -> Bool
+primop   IntGtOp  ">$#"   Compare   Int# -> Int# -> Int#
    with fixity = infix 4
 
-primop   IntGeOp  ">=#"   Compare   Int# -> Int# -> Bool
+primop   IntGeOp  ">=$#"   Compare   Int# -> Int# -> Int#
    with fixity = infix 4
 
-primop   IntEqOp  "==#"   Compare
-   Int# -> Int# -> Bool
+primop   IntEqOp  "==$#"   Compare
+   Int# -> Int# -> Int#
    with commutable = True
         fixity = infix 4
 
-primop   IntNeOp  "/=#"   Compare
-   Int# -> Int# -> Bool
+primop   IntNeOp  "/=$#"   Compare
+   Int# -> Int# -> Int#
    with commutable = True
         fixity = infix 4
 
-primop   IntLtOp  "<#"   Compare   Int# -> Int# -> Bool
+primop   IntLtOp  "<$#"   Compare   Int# -> Int# -> Int#
    with fixity = infix 4
 
-primop   IntLeOp  "<=#"   Compare   Int# -> Int# -> Bool
+primop   IntLeOp  "<=$#"   Compare   Int# -> Int# -> Int#
    with fixity = infix 4
 
 primop   ChrOp   "chr#"   GenPrimOp   Int# -> Char#
@@ -345,12 +345,12 @@ primop   SrlOp   "uncheckedShiftRL#"   GenPrimOp   Word# -> Int# -> Word#
 primop   Word2IntOp   "word2Int#"   GenPrimOp   Word# -> Int#
    with code_size = 0
 
-primop   WordGtOp   "gtWord#"   Compare   Word# -> Word# -> Bool
-primop   WordGeOp   "geWord#"   Compare   Word# -> Word# -> Bool
-primop   WordEqOp   "eqWord#"   Compare   Word# -> Word# -> Bool
-primop   WordNeOp   "neWord#"   Compare   Word# -> Word# -> Bool
-primop   WordLtOp   "ltWord#"   Compare   Word# -> Word# -> Bool
-primop   WordLeOp   "leWord#"   Compare   Word# -> Word# -> Bool
+primop   WordGtOp   "gtWordI#"   Compare   Word# -> Word# -> Int#
+primop   WordGeOp   "geWordI#"   Compare   Word# -> Word# -> Int#
+primop   WordEqOp   "eqWordI#"   Compare   Word# -> Word# -> Int#
+primop   WordNeOp   "neWordI#"   Compare   Word# -> Word# -> Int#
+primop   WordLtOp   "ltWordI#"   Compare   Word# -> Word# -> Int#
+primop   WordLeOp   "leWordI#"   Compare   Word# -> Word# -> Int#
 
 primop   PopCnt8Op   "popCnt8#"   Monadic   Word# -> Word#
     {Count the number of set bits in the lower 8 bits of a word.}
@@ -435,26 +435,26 @@ section "Double#"
 
 primtype Double#
 
-primop   DoubleGtOp ">##"   Compare   Double# -> Double# -> Bool
+primop   DoubleGtOp ">$##"   Compare   Double# -> Double# -> Int#
    with fixity = infix 4
 
-primop   DoubleGeOp ">=##"   Compare   Double# -> Double# -> Bool
+primop   DoubleGeOp ">=$##"   Compare   Double# -> Double# -> Int#
    with fixity = infix 4
 
-primop DoubleEqOp "==##"   Compare
-   Double# -> Double# -> Bool
+primop DoubleEqOp "==$##"   Compare
+   Double# -> Double# -> Int#
    with commutable = True
         fixity = infix 4
 
-primop DoubleNeOp "/=##"   Compare
-   Double# -> Double# -> Bool
+primop DoubleNeOp "/=$##"   Compare
+   Double# -> Double# -> Int#
    with commutable = True
         fixity = infix 4
 
-primop   DoubleLtOp "<##"   Compare   Double# -> Double# -> Bool
+primop   DoubleLtOp "<$##"   Compare   Double# -> Double# -> Int#
    with fixity = infix 4
 
-primop   DoubleLeOp "<=##"   Compare   Double# -> Double# -> Bool
+primop   DoubleLeOp "<=$##"   Compare   Double# -> Double# -> Int#
    with fixity = infix 4
 
 primop   DoubleAddOp   "+##"   Dyadic
@@ -568,19 +568,19 @@ section "Float#"
 
 primtype Float#
 
-primop   FloatGtOp  "gtFloat#"   Compare   Float# -> Float# -> Bool
-primop   FloatGeOp  "geFloat#"   Compare   Float# -> Float# -> Bool
+primop   FloatGtOp  "gtFloatI#"   Compare   Float# -> Float# -> Int#
+primop   FloatGeOp  "geFloatI#"   Compare   Float# -> Float# -> Int#
 
-primop   FloatEqOp  "eqFloat#"   Compare
-   Float# -> Float# -> Bool
+primop   FloatEqOp  "eqFloatI#"   Compare
+   Float# -> Float# -> Int#
    with commutable = True
 
-primop   FloatNeOp  "neFloat#"   Compare
-   Float# -> Float# -> Bool
+primop   FloatNeOp  "neFloatI#"   Compare
+   Float# -> Float# -> Int#
    with commutable = True
 
-primop   FloatLtOp  "ltFloat#"   Compare   Float# -> Float# -> Bool
-primop   FloatLeOp  "leFloat#"   Compare   Float# -> Float# -> Bool
+primop   FloatLtOp  "ltFloatI#"   Compare   Float# -> Float# -> Int#
+primop   FloatLeOp  "leFloatI#"   Compare   Float# -> Float# -> Int#
 
 primop   FloatAddOp   "plusFloat#"      Dyadic            
    Float# -> Float# -> Float#
@@ -698,7 +698,7 @@ primop  NewArrayOp "newArray#" GenPrimOp
    has_side_effects = True
 
 primop  SameMutableArrayOp "sameMutableArray#" GenPrimOp
-   MutableArray# s a -> MutableArray# s a -> Bool
+   MutableArray# s a -> MutableArray# s a -> Int#
 
 primop  ReadArrayOp "readArray#" GenPrimOp
    MutableArray# s a -> Int# -> State# s -> (# State# s, a #)
@@ -837,7 +837,7 @@ primop  ByteArrayContents_Char "byteArrayContents#" GenPrimOp
    {Intended for use with pinned arrays; otherwise very unsafe!}
 
 primop  SameMutableByteArrayOp "sameMutableByteArray#" GenPrimOp
-   MutableByteArray# s -> MutableByteArray# s -> Bool
+   MutableByteArray# s -> MutableByteArray# s -> Int#
 
 primop  UnsafeFreezeByteArrayOp "unsafeFreezeByteArray#" GenPrimOp
    MutableByteArray# s -> State# s -> (# State# s, ByteArray# #)
@@ -1133,7 +1133,7 @@ primop  NewArrayArrayOp "newArrayArray#" GenPrimOp
    has_side_effects = True
 
 primop  SameMutableArrayArrayOp "sameMutableArrayArray#" GenPrimOp
-   MutableArrayArray# s -> MutableArrayArray# s -> Bool
+   MutableArrayArray# s -> MutableArrayArray# s -> Int#
 
 primop  UnsafeFreezeArrayArrayOp "unsafeFreezeArrayArray#" GenPrimOp
    MutableArrayArray# s -> State# s -> (# State# s, ArrayArray# #)
@@ -1244,12 +1244,12 @@ primop   Int2AddrOp   "int2Addr#"    GenPrimOp  Int# -> Addr#
    with code_size = 0
 #endif
 
-primop   AddrGtOp  "gtAddr#"   Compare   Addr# -> Addr# -> Bool
-primop   AddrGeOp  "geAddr#"   Compare   Addr# -> Addr# -> Bool
-primop   AddrEqOp  "eqAddr#"   Compare   Addr# -> Addr# -> Bool
-primop   AddrNeOp  "neAddr#"   Compare   Addr# -> Addr# -> Bool
-primop   AddrLtOp  "ltAddr#"   Compare   Addr# -> Addr# -> Bool
-primop   AddrLeOp  "leAddr#"   Compare   Addr# -> Addr# -> Bool
+primop   AddrGtOp  "gtAddrI#"   Compare   Addr# -> Addr# -> Int#
+primop   AddrGeOp  "geAddrI#"   Compare   Addr# -> Addr# -> Int#
+primop   AddrEqOp  "eqAddrI#"   Compare   Addr# -> Addr# -> Int#
+primop   AddrNeOp  "neAddrI#"   Compare   Addr# -> Addr# -> Int#
+primop   AddrLtOp  "ltAddrI#"   Compare   Addr# -> Addr# -> Int#
+primop   AddrLeOp  "leAddrI#"   Compare   Addr# -> Addr# -> Int#
 
 primop IndexOffAddrOp_Char "indexCharOffAddr#" GenPrimOp
    Addr# -> Int# -> Char#
@@ -1510,7 +1510,7 @@ primop  WriteMutVarOp "writeMutVar#"  GenPrimOp
    can_fail         = True
 
 primop  SameMutVarOp "sameMutVar#" GenPrimOp
-   MutVar# s a -> MutVar# s a -> Bool
+   MutVar# s a -> MutVar# s a -> Int#
 
 -- not really the right type, but we don't know about pairs here.  The
 -- correct type is
@@ -1689,7 +1689,7 @@ primop    WriteTVarOp "writeTVar#" GenPrimOp
    has_side_effects = True
 
 primop  SameTVarOp "sameTVar#" GenPrimOp
-   TVar# s a -> TVar# s a -> Bool
+   TVar# s a -> TVar# s a -> Int#
 
 
 ------------------------------------------------------------------------
@@ -1759,7 +1759,7 @@ primop  TryReadMVarOp "tryReadMVar#" GenPrimOp
    has_side_effects = True
 
 primop  SameMVarOp "sameMVar#" GenPrimOp
-   MVar# s a -> MVar# s a -> Bool
+   MVar# s a -> MVar# s a -> Int#
 
 primop  IsEmptyMVarOp "isEmptyMVar#" GenPrimOp
    MVar# s a -> State# s -> (# State# s, Int# #)
index ebb5b85..0a69165 100644 (file)
@@ -404,7 +404,7 @@ renameDeriv is_boot inst_infos bagBinds
 
   | otherwise
   = discardWarnings $         -- Discard warnings about unused bindings etc
-    setXOptM Opt_EmptyCase $  -- Derived decls (for empty types) can have 
+    setXOptM Opt_EmptyCase $  -- Derived decls (for empty types) can have
                               --    case x of {}
     do  {
         -- Bring the extra deriving stuff into scope
@@ -764,7 +764,7 @@ if there are any overlaps.
 There are two other things that might go wrong with the lookup.
 First, we might see a standalone deriving clause
    deriving Eq (F ())
-when there is no data instance F () in scope. 
+when there is no data instance F () in scope.
 
 Note that it's OK to have
   data instance F [a] = ...
@@ -796,7 +796,7 @@ When type familes are involved it's trickier:
 
     instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
        -- d1 :: Monad []
-       -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT)) 
+       -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT))
 
 Note the need for the eta-reduced rule axioms.  After all, we can
 write it out
@@ -912,7 +912,7 @@ mkPolyKindedTypeableEqn orig tvs cls _cls_tys tycon tc_args mtheta
                      , ds_tc = tycon, ds_tc_args = tc_args
                      , ds_theta = mtheta `orElse` []  -- Context is empty for polykinded Typeable
                      , ds_newtype = False })  }
-  where 
+  where
     is_kind_var tc_arg = case tcGetTyVar_maybe tc_arg of
                            Just v  -> isKindVar v
                            Nothing -> False
@@ -1002,16 +1002,10 @@ ghc-prim does not use Functor or Typeable implicitly via these lookups.
 Note [Deriving and unboxed types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We have some special hacks to support things like
-   data T = MkT Int# deriving( Ord, Show )
-
-Specifically
-  * For Show we use TcGenDeriv.box_if_necy to box the Int# into an Int
-    (which we know how to show)
+   data T = MkT Int# deriving ( Show )
 
-  * For Eq, Ord, we ust TcGenDeriv.primOrdOps to give Ord operations
-    on some primitive types
-
-It's all a bit ad hoc.
+Specifically, we use TcGenDeriv.box_if_necy to box the Int# into an Int
+(which we know how to show). It's a bit ad hoc.
 
 
 \begin{code}
@@ -1610,7 +1604,7 @@ extendLocalInstEnv dfuns thing_inside
 
 
 ***********************************************************************************
-*                                                                                 * 
+*                                                                                 *
 *            Simplify derived constraints
 *                                                                                 *
 ***********************************************************************************
@@ -1618,16 +1612,16 @@ extendLocalInstEnv dfuns thing_inside
 \begin{code}
 simplifyDeriv :: CtOrigin
               -> PredType
-              -> [TyVar]        
+              -> [TyVar]
               -> ThetaType              -- Wanted
               -> TcM ThetaType  -- Needed
--- Given  instance (wanted) => C inst_ty 
+-- Given  instance (wanted) => C inst_ty
 -- Simplify 'wanted' as much as possibles
 -- Fail if not possible
-simplifyDeriv orig pred tvs theta 
+simplifyDeriv orig pred tvs theta
   = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize
-                -- The constraint solving machinery 
-                -- expects *TcTyVars* not TyVars.  
+                -- The constraint solving machinery
+                -- expects *TcTyVars* not TyVars.
                 -- We use *non-overlappable* (vanilla) skolems
                 -- See Note [Overlap and deriving]
 
@@ -1637,7 +1631,7 @@ simplifyDeriv orig pred tvs theta
 
        ; wanted <- newFlatWanteds orig (substTheta skol_subst theta)
 
-       ; traceTc "simplifyDeriv" $ 
+       ; traceTc "simplifyDeriv" $
          vcat [ pprTvBndrs tvs $$ ppr theta $$ ppr wanted, doc ]
        ; (residual_wanted, _ev_binds1)
              <- solveWantedsTcM (mkFlatWC wanted)
@@ -1646,8 +1640,8 @@ simplifyDeriv orig pred tvs theta
        ; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted)
                          -- See Note [Exotic derived instance contexts]
              get_good :: Ct -> Either PredType Ct
-             get_good ct | validDerivPred skol_set p 
-                         , isWantedCt ct  = Left p 
+             get_good ct | validDerivPred skol_set p
+                         , isWantedCt ct  = Left p
                          -- NB: residual_wanted may contain unsolved
                          -- Derived and we stick them into the bad set
                          -- so that reportUnsolved may decide what to do with them
@@ -1684,7 +1678,7 @@ and we want to infer
    f :: Show [a] => a -> String
 
 BOTTOM LINE: use vanilla, non-overlappable skolems when inferring
-             the context for the derived instance. 
+             the context for the derived instance.
              Hence tcInstSkolTyVars not tcInstSuperSkolTyVars
 
 Note [Exotic derived instance contexts]
@@ -1699,13 +1693,13 @@ One could go further: consider
         data T a b c = MkT (Foo a b c) deriving( Eq )
         instance (C Int a, Eq b, Eq c) => Eq (Foo a b c)
 
-Notice that this instance (just) satisfies the Paterson termination 
+Notice that this instance (just) satisfies the Paterson termination
 conditions.  Then we *could* derive an instance decl like this:
 
-        instance (C Int a, Eq b, Eq c) => Eq (T a b c) 
+        instance (C Int a, Eq b, Eq c) => Eq (T a b c)
 even though there is no instance for (C Int a), because there just
 *might* be an instance for, say, (C Int Bool) at a site where we
-need the equality instance for T's.  
+need the equality instance for T's.
 
 However, this seems pretty exotic, and it's quite tricky to allow
 this, and yet give sensible error messages in the (much more common)
index 77bda82..045978f 100644 (file)
@@ -1,4 +1,4 @@
-%
+    %
 % (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
@@ -477,21 +477,21 @@ unliftedOrdOp tycon ty op a b
        OrdGT      -> wrap gt_op
   where
    (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" tycon ty
-   wrap prim_op = genOpApp a_expr (primOpRdrName prim_op) b_expr
+   wrap prim_op = genOpApp a_expr prim_op b_expr
    a_expr = nlHsVar a
    b_expr = nlHsVar b
 
-unliftedCompare :: PrimOp -> PrimOp
+unliftedCompare :: RdrName -> RdrName
                 -> LHsExpr RdrName -> LHsExpr RdrName   -- What to cmpare
                 -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName  -- Three results
                 -> LHsExpr RdrName
 -- Return (if a < b then lt else if a == b then eq else gt)
 unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
-  = nlHsIf (genOpApp a_expr (primOpRdrName lt_op) b_expr) lt $
+  = nlHsIf (genOpApp a_expr lt_op b_expr) lt $
                         -- Test (<) first, not (==), because the latter
                         -- is true less often, so putting it first would
                         -- mean more tests (dynamically)
-        nlHsIf (genOpApp a_expr (primOpRdrName eq_op) b_expr) eq gt
+        nlHsIf (genOpApp a_expr eq_op b_expr) eq gt
 
 nlConWildPat :: DataCon -> LPat RdrName
 -- The pattern (K {})
@@ -872,7 +872,7 @@ instance Read T where
 
 Note [Use expectP]
 ~~~~~~~~~~~~~~~~~~
-Note that we use 
+Note that we use
    expectP (Ident "T1")
 rather than
    Ident "T1" <- lexP
@@ -888,7 +888,7 @@ What should we get for this?  (Trac #7931)
 
 Here we want
   read "[]" :: [Emp]   to succeed, returning []
-So we do NOT want 
+So we do NOT want
    instance Read Emp where
      readPrec = error "urk"
 Rather we want
@@ -896,7 +896,7 @@ Rather we want
      readPred = pfail   -- Same as choose []
 
 Because 'pfail' allows the parser to backtrack, but 'error' doesn't.
-These instances are also useful for Read (Either Int Emp), where 
+These instances are also useful for Read (Either Int Emp), where
 we want to be able to parse (Left 3) just fine.
 
 \begin{code}
@@ -1442,7 +1442,13 @@ kind2 = liftedTypeKind `mkArrowKind` kind1
 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
     mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
     dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
-    constr_RDR, dataType_RDR :: RdrName
+    constr_RDR, dataType_RDR,
+    eqChar_RDR  , ltChar_RDR  , geChar_RDR  , gtChar_RDR  , leChar_RDR  ,
+    eqInt_RDR   , ltInt_RDR   , geInt_RDR   , gtInt_RDR   , leInt_RDR   ,
+    eqWord_RDR  , ltWord_RDR  , geWord_RDR  , gtWord_RDR  , leWord_RDR  ,
+    eqAddr_RDR  , ltAddr_RDR  , geAddr_RDR  , gtAddr_RDR  , leAddr_RDR  ,
+    eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
+    eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR :: RdrName
 gfoldl_RDR     = varQual_RDR  gENERICS (fsLit "gfoldl")
 gunfold_RDR    = varQual_RDR  gENERICS (fsLit "gunfold")
 toConstr_RDR   = varQual_RDR  gENERICS (fsLit "toConstr")
@@ -1458,6 +1464,42 @@ dataType_RDR   = tcQual_RDR   gENERICS (fsLit "DataType")
 conIndex_RDR   = varQual_RDR  gENERICS (fsLit "constrIndex")
 prefix_RDR     = dataQual_RDR gENERICS (fsLit "Prefix")
 infix_RDR      = dataQual_RDR gENERICS (fsLit "Infix")
+
+eqChar_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "eqChar#")
+ltChar_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "ltChar#")
+leChar_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "leChar#")
+gtChar_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "gtChar#")
+geChar_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "geChar#")
+
+eqInt_RDR      = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "==#")
+ltInt_RDR      = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "<#" )
+leInt_RDR      = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "<=#")
+gtInt_RDR      = varQual_RDR  gHC_PRIMWRAPPERS (fsLit ">#" )
+geInt_RDR      = varQual_RDR  gHC_PRIMWRAPPERS (fsLit ">=#")
+
+eqWord_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "eqWord#")
+ltWord_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "ltWord#")
+leWord_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "leWord#")
+gtWord_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "gtWord#")
+geWord_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "geWord#")
+
+eqAddr_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "eqAddr#")
+ltAddr_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "ltAddr#")
+leAddr_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "leAddr#")
+gtAddr_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "gtAddr#")
+geAddr_RDR     = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "geAddr#")
+
+eqFloat_RDR    = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "eqFloat#")
+ltFloat_RDR    = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "ltFloat#")
+leFloat_RDR    = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "leFloat#")
+gtFloat_RDR    = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "gtFloat#")
+geFloat_RDR    = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "geFloat#")
+
+eqDouble_RDR   = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "==##")
+ltDouble_RDR   = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "<##" )
+leDouble_RDR   = varQual_RDR  gHC_PRIMWRAPPERS (fsLit "<=##")
+gtDouble_RDR   = varQual_RDR  gHC_PRIMWRAPPERS (fsLit ">##" )
+geDouble_RDR   = varQual_RDR  gHC_PRIMWRAPPERS (fsLit ">=##")
 \end{code}
 
 
@@ -1569,7 +1611,7 @@ gen_Functor_binds loc tycon
                  , ft_fun  = \g h -> do                      -- fmap f = \x b -> h (x (g b))
                                  gg <- g
                                  hh <- h
-                                 mkSimpleLam2 $ \x b -> return $ nlHsApp hh (nlHsApp x (nlHsApp gg b)) 
+                                 mkSimpleLam2 $ \x b -> return $ nlHsApp hh (nlHsApp x (nlHsApp gg b))
                  , ft_tup = \t gs -> do                      -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
                                  gg <- sequence gs
                                  mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
@@ -1777,7 +1819,7 @@ gen_Foldable_binds loc tycon
                     , ft_co_var = panic "contravariant"
                     , ft_fun = panic "function"
                     , ft_bad_app = panic "in other argument" }
-    
+
     match_foldMap = mkSimpleConMatch $ \_con_name xs -> return $
         case xs of
             [] -> mempty_Expr
@@ -2003,26 +2045,26 @@ box_if_necy cls_str tycon arg arg_ty
 primOrdOps :: String    -- The class involved
            -> TyCon     -- The tycon involved
            -> Type      -- The type
-           -> (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp)  -- (lt,le,eq,ge,gt)
+           -> (RdrName, RdrName, RdrName, RdrName, RdrName)  -- (lt,le,eq,ge,gt)
 -- See Note [Deriving and unboxed types]
 primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
 
-ordOpTbl :: [(Type, (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp))]
+ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
 ordOpTbl
- =  [(charPrimTy,       (CharLtOp,   CharLeOp,   CharEqOp,   CharGeOp,   CharGtOp))
-    ,(intPrimTy,        (IntLtOp,    IntLeOp,    IntEqOp,    IntGeOp,    IntGtOp))
-    ,(wordPrimTy,       (WordLtOp,   WordLeOp,   WordEqOp,   WordGeOp,   WordGtOp))
-    ,(addrPrimTy,       (AddrLtOp,   AddrLeOp,   AddrEqOp,   AddrGeOp,   AddrGtOp))
-    ,(floatPrimTy,      (FloatLtOp,  FloatLeOp,  FloatEqOp,  FloatGeOp,  FloatGtOp))
-    ,(doublePrimTy,     (DoubleLtOp, DoubleLeOp, DoubleEqOp, DoubleGeOp, DoubleGtOp)) ]
+ =  [(charPrimTy  , (ltChar_RDR  , leChar_RDR  , eqChar_RDR  , geChar_RDR  , gtChar_RDR  ))
+    ,(intPrimTy   , (ltInt_RDR   , leInt_RDR   , eqInt_RDR   , geInt_RDR   , gtInt_RDR   ))
+    ,(wordPrimTy  , (ltWord_RDR  , leWord_RDR  , eqWord_RDR  , geWord_RDR  , gtWord_RDR  ))
+    ,(addrPrimTy  , (ltAddr_RDR  , leAddr_RDR  , eqAddr_RDR  , geAddr_RDR  , gtAddr_RDR  ))
+    ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
+    ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
 
 boxConTbl :: [(Type, RdrName)]
 boxConTbl
-  = [(charPrimTy,       getRdrName charDataCon)
-    ,(intPrimTy,        getRdrName intDataCon)
-    ,(wordPrimTy,       wordDataCon_RDR)
-    ,(floatPrimTy,      getRdrName floatDataCon)
-    ,(doublePrimTy,     getRdrName doubleDataCon)
+  = [(charPrimTy  , getRdrName charDataCon  )
+    ,(intPrimTy   , getRdrName intDataCon   )
+    ,(wordPrimTy  , getRdrName wordDataCon  )
+    ,(floatPrimTy , getRdrName floatDataCon )
+    ,(doublePrimTy, getRdrName doubleDataCon)
     ]
 
 assoc_ty_id :: String           -- The class involved
@@ -2045,10 +2087,10 @@ and_Expr a b = genOpApp a and_RDR    b
 -----------------------------------------------------------------------
 
 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
-eq_Expr tycon ty a b = genOpApp a eq_op b
+eq_Expr tycon ty a b
+    | not (isUnLiftedType ty) = genOpApp a eq_RDR b
+    | otherwise               = genOpApp a prim_eq b
  where
-   eq_op | not (isUnLiftedType ty) = eq_RDR
-         | otherwise               = primOpRdrName prim_eq
    (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
 \end{code}
 
@@ -2184,25 +2226,9 @@ mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent))
 -- Was: mkDerivedRdrName name occ_fun, which made an original name
 -- But:  (a) that does not work well for standalone-deriving
 --       (b) an unqualified name is just fine, provided it can't clash with user code
-\end{code}
-
-s RdrName for PrimOps.  Can't be done in PrelNames, because PrimOp imports
-PrelNames, so PrelNames can't import PrimOp.
 
-\begin{code}
-primOpRdrName :: PrimOp -> RdrName
-primOpRdrName op = getRdrName (primOpId op)
-
-minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, gtInt_RDR, leInt_RDR,
-    tagToEnum_RDR :: RdrName
-minusInt_RDR  = primOpRdrName IntSubOp
-eqInt_RDR     = primOpRdrName IntEqOp
-ltInt_RDR     = primOpRdrName IntLtOp
-geInt_RDR     = primOpRdrName IntGeOp
-gtInt_RDR     = primOpRdrName IntGtOp
-leInt_RDR     = primOpRdrName IntLeOp
-tagToEnum_RDR = primOpRdrName TagToEnumOp
-
-error_RDR :: RdrName
-error_RDR = getRdrName eRROR_ID
+minusInt_RDR, tagToEnum_RDR, error_RDR :: RdrName
+minusInt_RDR  = getRdrName (primOpId IntSubOp   )
+tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
+error_RDR     = getRdrName eRROR_ID
 \end{code}
index ef0112e..46c6fa4 100644 (file)
 
         <listitem>
             <para>
+                PrimOps for comparing unboxed values now return
+                <literal>Int#</literal> instead of <literal>Bool</literal>.
+                New PrimOps' names end with <literal>$#</literal> for operators and
+                <literal>I#</literal> for ordinary names, e.g. <literal>==$#</literal>
+                compares <literal>Int#</literal>s for equality and
+                <literal>eqCharI#</literal> does the same for <literal>Char#</literal>s.
+                Old PrimOps have been removed and turned into wrappers. If your
+                code relied on removed PrimOps then importing
+                <literal>GHC.PrimWrappers</literal> will make it work again (no
+                need to add anything if your code already imports
+                <literal>GHC.Exts</literal>).
+           </para>
+       </listitem>
+
+        <listitem>
+            <para>
                 TODO: mention dynamic changes
            </para>
        </listitem>
index 75c3379..c6b1e20 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 75c3379b6d76e914cc3c7ffd290b6b1cad7ea3e6
+Subproject commit c6b1e204f0f2a1a0d6cb1df35fa60762b2fe3cdc
index 4230cd8..8729d4c 100644 (file)
@@ -138,8 +138,6 @@ gen_hs_source (Info defaults entries) =
         ++ unlines (map (("\t" ++) . hdr) entries)
         ++ ") where\n"
     ++ "\n"
-    ++ "import GHC.Types\n"
-    ++ "\n"
     ++ "{-\n"
         ++ unlines (map opt defaults)
     ++ "-}\n"
@@ -507,7 +505,6 @@ gen_wrappers (Info _ entries)
         -- don't need the Prelude here so we add NoImplicitPrelude.
      ++ "module GHC.PrimopWrappers where\n" 
      ++ "import qualified GHC.Prim\n" 
-     ++ "import GHC.Types (Bool)\n"
      ++ "import GHC.Tuple ()\n"
      ++ "import GHC.Prim (" ++ concat (intersperse ", " othertycons) ++ ")\n"
      ++ "#if defined (__GLASGOW_HASKELL_LLVM__)\n"
index b2e983d..9d13f91 100644 (file)
@@ -114,7 +114,7 @@ sanityPrimOp def_names p
 
 sane_ty :: Category -> Ty -> Bool
 sane_ty Compare (TyF t1 (TyF t2 td)) 
-   | t1 == t2 && td == TyApp "Bool" []  = True
+   | t1 == t2 && td == TyApp "Int#" []  = True
 sane_ty Monadic (TyF t1 td) 
    | t1 == td  = True
 sane_ty Dyadic (TyF t1 (TyF t2 td))