From: qrczak Date: Sat, 28 Apr 2001 11:21:32 +0000 (+0000) Subject: [project @ 2001-04-28 11:21:32 by qrczak] X-Git-Tag: Approximately_9120_patches~2075 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;ds=sidebyside;h=5577dc396e77a448e2530ca1eab2850300ba316f;p=ghc-hetmet.git [project @ 2001-04-28 11:21:32 by qrczak] Add a builtin rule to a primop only if it does something. --- diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index fb7fff8..e1ba24d 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -118,7 +118,7 @@ wiredInIds , rEC_CON_ERROR_ID , rEC_UPD_ERROR_ID - -- These two can't be defined in Haskell + -- These three can't be defined in Haskell , realWorldPrimId , unsafeCoerceId , getTagId @@ -573,7 +573,8 @@ mkPrimOpId prim_op `setArityInfo` exactArity arity `setStrictnessInfo` strict_info - rules = addRule emptyCoreRules id (primOpRule prim_op) + rules = maybe emptyCoreRules (addRule emptyCoreRules id) + (primOpRule prim_op) -- For each ccall we manufacture a separate CCallOpId, giving it diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index 4e0bb74..b6e0e75 100644 --- a/ghc/compiler/prelude/PrelRules.lhs +++ b/ghc/compiler/prelude/PrelRules.lhs @@ -48,9 +48,8 @@ import CmdLineOpts ( opt_SimplExcessPrecision ) \begin{code} -primOpRule :: PrimOp -> CoreRule -primOpRule op - = BuiltinRule (primop_rule op) +primOpRule :: PrimOp -> Maybe CoreRule +primOpRule op = fmap BuiltinRule (primop_rule op) where op_name = _PK_ (occNameUserString (primOpOcc op)) op_name_case = op_name _APPEND_ SLIT("->case") @@ -58,105 +57,105 @@ primOpRule op -- ToDo: something for integer-shift ops? -- NotOp - primop_rule SeqOp = seqRule - primop_rule TagToEnumOp = tagToEnumRule - primop_rule DataToTagOp = dataToTagRule + primop_rule SeqOp = Just seqRule + primop_rule TagToEnumOp = Just tagToEnumRule + primop_rule DataToTagOp = Just dataToTagRule -- Int operations - primop_rule IntAddOp = twoLits (intOp2 (+) op_name) - primop_rule IntSubOp = twoLits (intOp2 (-) op_name) - primop_rule IntMulOp = twoLits (intOp2 (*) op_name) - primop_rule IntQuotOp = twoLits (intOp2Z quot op_name) - primop_rule IntRemOp = twoLits (intOp2Z rem op_name) - primop_rule IntNegOp = oneLit (negOp op_name) + primop_rule IntAddOp = Just (twoLits (intOp2 (+) op_name)) + primop_rule IntSubOp = Just (twoLits (intOp2 (-) op_name)) + primop_rule IntMulOp = Just (twoLits (intOp2 (*) op_name)) + primop_rule IntQuotOp = Just (twoLits (intOp2Z quot op_name)) + primop_rule IntRemOp = Just (twoLits (intOp2Z rem op_name)) + primop_rule IntNegOp = Just (oneLit (negOp op_name)) -- Word operations #if __GLASGOW_HASKELL__ >= 500 - primop_rule WordAddOp = twoLits (wordOp2 (+) op_name) - primop_rule WordSubOp = twoLits (wordOp2 (-) op_name) - primop_rule WordMulOp = twoLits (wordOp2 (*) op_name) + primop_rule WordAddOp = Just (twoLits (wordOp2 (+) op_name)) + primop_rule WordSubOp = Just (twoLits (wordOp2 (-) op_name)) + primop_rule WordMulOp = Just (twoLits (wordOp2 (*) op_name)) #endif - primop_rule WordQuotOp = twoLits (wordOp2Z quot op_name) - primop_rule WordRemOp = twoLits (wordOp2Z rem op_name) + primop_rule WordQuotOp = Just (twoLits (wordOp2Z quot op_name)) + primop_rule WordRemOp = Just (twoLits (wordOp2Z rem op_name)) #if __GLASGOW_HASKELL__ >= 407 - primop_rule AndOp = twoLits (wordBitOp2 (.&.) op_name) - primop_rule OrOp = twoLits (wordBitOp2 (.|.) op_name) - primop_rule XorOp = twoLits (wordBitOp2 xor op_name) + primop_rule AndOp = Just (twoLits (wordBitOp2 (.&.) op_name)) + primop_rule OrOp = Just (twoLits (wordBitOp2 (.|.) op_name)) + primop_rule XorOp = Just (twoLits (wordBitOp2 xor op_name)) #endif -- coercions - primop_rule Word2IntOp = oneLit (litCoerce word2IntLit op_name) - primop_rule Int2WordOp = oneLit (litCoerce int2WordLit op_name) - primop_rule IntToInt8Op = oneLit (litCoerce intToInt8Lit op_name) - primop_rule IntToInt16Op = oneLit (litCoerce intToInt16Lit op_name) - primop_rule IntToInt32Op = oneLit (litCoerce intToInt32Lit op_name) - primop_rule WordToWord8Op = oneLit (litCoerce wordToWord8Lit op_name) - primop_rule WordToWord16Op = oneLit (litCoerce wordToWord16Lit op_name) - primop_rule WordToWord32Op = oneLit (litCoerce wordToWord32Lit op_name) - primop_rule OrdOp = oneLit (litCoerce char2IntLit op_name) - primop_rule ChrOp = oneLit (litCoerce int2CharLit op_name) - primop_rule Float2IntOp = oneLit (litCoerce float2IntLit op_name) - primop_rule Int2FloatOp = oneLit (litCoerce int2FloatLit op_name) - primop_rule Double2IntOp = oneLit (litCoerce double2IntLit op_name) - primop_rule Int2DoubleOp = oneLit (litCoerce int2DoubleLit op_name) - primop_rule Addr2IntOp = oneLit (litCoerce addr2IntLit op_name) - primop_rule Int2AddrOp = oneLit (litCoerce int2AddrLit op_name) + primop_rule Word2IntOp = Just (oneLit (litCoerce word2IntLit op_name)) + primop_rule Int2WordOp = Just (oneLit (litCoerce int2WordLit op_name)) + primop_rule IntToInt8Op = Just (oneLit (litCoerce intToInt8Lit op_name)) + primop_rule IntToInt16Op = Just (oneLit (litCoerce intToInt16Lit op_name)) + primop_rule IntToInt32Op = Just (oneLit (litCoerce intToInt32Lit op_name)) + primop_rule WordToWord8Op = Just (oneLit (litCoerce wordToWord8Lit op_name)) + primop_rule WordToWord16Op = Just (oneLit (litCoerce wordToWord16Lit op_name)) + primop_rule WordToWord32Op = Just (oneLit (litCoerce wordToWord32Lit op_name)) + primop_rule OrdOp = Just (oneLit (litCoerce char2IntLit op_name)) + primop_rule ChrOp = Just (oneLit (litCoerce int2CharLit op_name)) + primop_rule Float2IntOp = Just (oneLit (litCoerce float2IntLit op_name)) + primop_rule Int2FloatOp = Just (oneLit (litCoerce int2FloatLit op_name)) + primop_rule Double2IntOp = Just (oneLit (litCoerce double2IntLit op_name)) + primop_rule Int2DoubleOp = Just (oneLit (litCoerce int2DoubleLit op_name)) + primop_rule Addr2IntOp = Just (oneLit (litCoerce addr2IntLit op_name)) + primop_rule Int2AddrOp = Just (oneLit (litCoerce int2AddrLit op_name)) -- SUP: Not sure what the standard says about precision in the following 2 cases - primop_rule Float2DoubleOp = oneLit (litCoerce float2DoubleLit op_name) - primop_rule Double2FloatOp = oneLit (litCoerce double2FloatLit op_name) + primop_rule Float2DoubleOp = Just (oneLit (litCoerce float2DoubleLit op_name)) + primop_rule Double2FloatOp = Just (oneLit (litCoerce double2FloatLit op_name)) -- Float - primop_rule FloatAddOp = twoLits (floatOp2 (+) op_name) - primop_rule FloatSubOp = twoLits (floatOp2 (-) op_name) - primop_rule FloatMulOp = twoLits (floatOp2 (*) op_name) - primop_rule FloatDivOp = twoLits (floatOp2Z (/) op_name) - primop_rule FloatNegOp = oneLit (negOp op_name) + primop_rule FloatAddOp = Just (twoLits (floatOp2 (+) op_name)) + primop_rule FloatSubOp = Just (twoLits (floatOp2 (-) op_name)) + primop_rule FloatMulOp = Just (twoLits (floatOp2 (*) op_name)) + primop_rule FloatDivOp = Just (twoLits (floatOp2Z (/) op_name)) + primop_rule FloatNegOp = Just (oneLit (negOp op_name)) -- Double - primop_rule DoubleAddOp = twoLits (doubleOp2 (+) op_name) - primop_rule DoubleSubOp = twoLits (doubleOp2 (-) op_name) - primop_rule DoubleMulOp = twoLits (doubleOp2 (*) op_name) - primop_rule DoubleDivOp = twoLits (doubleOp2Z (/) op_name) - primop_rule DoubleNegOp = oneLit (negOp op_name) + primop_rule DoubleAddOp = Just (twoLits (doubleOp2 (+) op_name)) + primop_rule DoubleSubOp = Just (twoLits (doubleOp2 (-) op_name)) + primop_rule DoubleMulOp = Just (twoLits (doubleOp2 (*) op_name)) + primop_rule DoubleDivOp = Just (twoLits (doubleOp2Z (/) op_name)) + primop_rule DoubleNegOp = Just (oneLit (negOp op_name)) -- Relational operators - primop_rule IntEqOp = relop (==) `or_rule` litEq True op_name_case - primop_rule IntNeOp = relop (/=) `or_rule` litEq False op_name_case - primop_rule CharEqOp = relop (==) `or_rule` litEq True op_name_case - primop_rule CharNeOp = relop (/=) `or_rule` litEq False op_name_case - - primop_rule IntGtOp = relop (>) - primop_rule IntGeOp = relop (>=) - primop_rule IntLeOp = relop (<=) - primop_rule IntLtOp = relop (<) - - primop_rule CharGtOp = relop (>) - primop_rule CharGeOp = relop (>=) - primop_rule CharLeOp = relop (<=) - primop_rule CharLtOp = relop (<) - - primop_rule FloatGtOp = relop (>) - primop_rule FloatGeOp = relop (>=) - primop_rule FloatLeOp = relop (<=) - primop_rule FloatLtOp = relop (<) - primop_rule FloatEqOp = relop (==) - primop_rule FloatNeOp = relop (/=) - - primop_rule DoubleGtOp = relop (>) - primop_rule DoubleGeOp = relop (>=) - primop_rule DoubleLeOp = relop (<=) - primop_rule DoubleLtOp = relop (<) - primop_rule DoubleEqOp = relop (==) - primop_rule DoubleNeOp = relop (/=) - - primop_rule WordGtOp = relop (>) - primop_rule WordGeOp = relop (>=) - primop_rule WordLeOp = relop (<=) - primop_rule WordLtOp = relop (<) - primop_rule WordEqOp = relop (==) - primop_rule WordNeOp = relop (/=) - - primop_rule other = \args -> Nothing + primop_rule IntEqOp = Just (relop (==) `or_rule` litEq True op_name_case) + primop_rule IntNeOp = Just (relop (/=) `or_rule` litEq False op_name_case) + primop_rule CharEqOp = Just (relop (==) `or_rule` litEq True op_name_case) + primop_rule CharNeOp = Just (relop (/=) `or_rule` litEq False op_name_case) + + primop_rule IntGtOp = Just (relop (>)) + primop_rule IntGeOp = Just (relop (>=)) + primop_rule IntLeOp = Just (relop (<=)) + primop_rule IntLtOp = Just (relop (<)) + + primop_rule CharGtOp = Just (relop (>)) + primop_rule CharGeOp = Just (relop (>=)) + primop_rule CharLeOp = Just (relop (<=)) + primop_rule CharLtOp = Just (relop (<)) + + primop_rule FloatGtOp = Just (relop (>)) + primop_rule FloatGeOp = Just (relop (>=)) + primop_rule FloatLeOp = Just (relop (<=)) + primop_rule FloatLtOp = Just (relop (<)) + primop_rule FloatEqOp = Just (relop (==)) + primop_rule FloatNeOp = Just (relop (/=)) + + primop_rule DoubleGtOp = Just (relop (>)) + primop_rule DoubleGeOp = Just (relop (>=)) + primop_rule DoubleLeOp = Just (relop (<=)) + primop_rule DoubleLtOp = Just (relop (<)) + primop_rule DoubleEqOp = Just (relop (==)) + primop_rule DoubleNeOp = Just (relop (/=)) + + primop_rule WordGtOp = Just (relop (>)) + primop_rule WordGeOp = Just (relop (>=)) + primop_rule WordLeOp = Just (relop (<=)) + primop_rule WordLtOp = Just (relop (<)) + primop_rule WordEqOp = Just (relop (==)) + primop_rule WordNeOp = Just (relop (/=)) + + primop_rule other = Nothing relop cmp = twoLits (cmpOp (\ord -> ord `cmp` EQ) op_name) @@ -324,11 +323,11 @@ or_rule r1 r2 args = maybe (r2 args) Just (r1 args) -- i.e.: r1 args `mplus` r2 twoLits :: (Literal -> Literal -> Maybe (RuleName, CoreExpr)) -> RuleFun twoLits rule [Lit l1, Lit l2] = rule (convFloating l1) (convFloating l2) -twoLits rule other = Nothing +twoLits rule _ = Nothing oneLit :: (Literal -> Maybe (RuleName, CoreExpr)) -> RuleFun oneLit rule [Lit l1] = rule (convFloating l1) -oneLit rule other = Nothing +oneLit rule _ = Nothing -- When excess precision is not requested, cut down the precision of the -- Rational value to that of Float/Double. We confuse host architecture