[commit: ghc] master: Add some more primop rules; fixes #7286 (e3d7889)
Ian Lynagh <[email protected]>
| Newsgroups | gmane.comp.lang.haskell.cvs.ghc |
|---|---|
| Message-ID | <[email protected]> |
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master http://hackage.haskell.org/trac/ghc/changeset/e3d78899ce336e8637ae231550c04f0f68bca2aa >--------------------------------------------------------------- commit e3d78899ce336e8637ae231550c04f0f68bca2aa Author: Ian Lynagh <[email protected]> Date: Sun Oct 21 13:48:09 2012 +0100 Add some more primop rules; fixes #7286 As well as the rules mentioned in the ticket, I've also gone through and added some more rules that might be useful in other cases. >--------------------------------------------------------------- compiler/prelude/PrelRules.lhs | 56 ++++++++++++++++++++++++++++++++-------- 1 files changed, 45 insertions(+), 11 deletions(-) diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 5d41494..3136b36 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -98,7 +98,8 @@ primOpRules nm IntRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intO retLit zeroi , equalArgs >> retLit zeroi , equalArgs >> retLit zeroi ] -primOpRules nm IntNegOp = mkPrimOpRule nm 1 [ unaryLit negOp ] +primOpRules nm IntNegOp = mkPrimOpRule nm 1 [ unaryLit negOp + , inversePrimOp IntNegOp ] primOpRules nm ISllOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftL) , rightIdentityDynFlags zeroi ] primOpRules nm ISraOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftR) @@ -135,18 +136,38 @@ primOpRules nm Word2IntOp = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit , inversePrimOp Int2WordOp ] primOpRules nm Int2WordOp = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit , inversePrimOp Word2IntOp ] -primOpRules nm Narrow8IntOp = mkPrimOpRule nm 1 [ liftLit narrow8IntLit ] -primOpRules nm Narrow16IntOp = mkPrimOpRule nm 1 [ liftLit narrow16IntLit ] +primOpRules nm Narrow8IntOp = mkPrimOpRule nm 1 [ liftLit narrow8IntLit + , subsumedByPrimOp Narrow8IntOp + , subsumedByPrimOp Narrow16IntOp + , subsumedByPrimOp Narrow32IntOp ] +primOpRules nm Narrow16IntOp = mkPrimOpRule nm 1 [ liftLit narrow16IntLit + , Narrow16IntOp `subsumesPrimOp` Narrow8IntOp + , subsumedByPrimOp Narrow16IntOp + , subsumedByPrimOp Narrow32IntOp ] primOpRules nm Narrow32IntOp = mkPrimOpRule nm 1 [ liftLit narrow32IntLit + , Narrow32IntOp `subsumesPrimOp` Narrow8IntOp + , Narrow32IntOp `subsumesPrimOp` Narrow16IntOp + , subsumedByPrimOp Narrow32IntOp , removeOp32 ] -primOpRules nm Narrow8WordOp = mkPrimOpRule nm 1 [ liftLit narrow8WordLit ] -primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit ] +primOpRules nm Narrow8WordOp = mkPrimOpRule nm 1 [ liftLit narrow8WordLit + , subsumedByPrimOp Narrow8WordOp + , subsumedByPrimOp Narrow16WordOp + , subsumedByPrimOp Narrow32WordOp ] +primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit + , Narrow16WordOp `subsumesPrimOp` Narrow8WordOp + , subsumedByPrimOp Narrow16WordOp + , subsumedByPrimOp Narrow32WordOp ] primOpRules nm Narrow32WordOp = mkPrimOpRule nm 1 [ liftLit narrow32WordLit + , Narrow32WordOp `subsumesPrimOp` Narrow8WordOp + , Narrow32WordOp `subsumesPrimOp` Narrow16WordOp + , subsumedByPrimOp Narrow32WordOp , removeOp32 ] -primOpRules nm OrdOp = mkPrimOpRule nm 1 [ liftLit char2IntLit ] -primOpRules nm ChrOp = mkPrimOpRule nm 1 [ do { [Lit lit] <- getArgs - ; guard (litFitsInChar lit) - ; liftLit int2CharLit } ] +primOpRules nm OrdOp = mkPrimOpRule nm 1 [ liftLit char2IntLit + , inversePrimOp ChrOp ] +primOpRules nm ChrOp = mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs + guard (litFitsInChar lit) + liftLit int2CharLit + , inversePrimOp OrdOp ] primOpRules nm Float2IntOp = mkPrimOpRule nm 1 [ liftLit float2IntLit ] primOpRules nm Int2FloatOp = mkPrimOpRule nm 1 [ liftLit int2FloatLit ] primOpRules nm Double2IntOp = mkPrimOpRule nm 1 [ liftLit double2IntLit ] @@ -165,7 +186,8 @@ primOpRules nm FloatMulOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*)) -- zeroElem zerof doesn't hold because of NaN primOpRules nm FloatDivOp = mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/)) , rightIdentity onef ] -primOpRules nm FloatNegOp = mkPrimOpRule nm 1 [ unaryLit negOp ] +primOpRules nm FloatNegOp = mkPrimOpRule nm 1 [ unaryLit negOp + , inversePrimOp FloatNegOp ] -- Double primOpRules nm DoubleAddOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+)) @@ -177,7 +199,8 @@ primOpRules nm DoubleMulOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*)) -- zeroElem zerod doesn't hold because of NaN primOpRules nm DoubleDivOp = mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/)) , rightIdentity oned ] -primOpRules nm DoubleNegOp = mkPrimOpRule nm 1 [ unaryLit negOp ] +primOpRules nm DoubleNegOp = mkPrimOpRule nm 1 [ unaryLit negOp + , inversePrimOp DoubleNegOp ] -- Relational operators primOpRules nm IntEqOp = mkRelOpRule nm (==) [ litEq True ] @@ -443,6 +466,17 @@ inversePrimOp primop = do matchPrimOpId primop primop_id return e +subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr +this `subsumesPrimOp` that = do + [Var primop_id `App` e] <- getArgs + matchPrimOpId that primop_id + return (Var (mkPrimOpId this) `App` e) + +subsumedByPrimOp :: PrimOp -> RuleM CoreExpr +subsumedByPrimOp primop = do + [e@(Var primop_id `App` _)] <- getArgs + matchPrimOpId primop primop_id + return e \end{code} %************************************************************************