[add various optimizations for binary operators
John Meacham <john@repetae.net>**20070531090110] hunk ./C/Op.hs 263
-commuteBinOp Lt = return Gte
-commuteBinOp Gt = return Lte
-commuteBinOp Lte = return Gt
-commuteBinOp Gte = return Lt
-commuteBinOp ULt = return UGte
-commuteBinOp UGt = return ULte
-commuteBinOp ULte = return UGt
-commuteBinOp UGte = return ULt
-commuteBinOp FLt = return FGte
-commuteBinOp FGt = return FLte
-commuteBinOp FLte = return FGt
-commuteBinOp FGte = return FLt
+commuteBinOp Lt = return Gt
+commuteBinOp Gt = return Lt
+commuteBinOp Lte = return Gte
+commuteBinOp Gte = return Lte
+commuteBinOp ULt = return UGt
+commuteBinOp UGt = return ULt
+commuteBinOp ULte = return UGte
+commuteBinOp UGte = return ULte
+commuteBinOp FLt = return FGt
+commuteBinOp FGt = return FLt
+commuteBinOp FLte = return FGte
+commuteBinOp FGte = return FLte
hunk ./C/OpEval.hs 12
-    toTy   :: t -> Ty
-    createBinOp :: BinOp -> e -> e -> e
-    fromBinOp :: e -> Maybe (BinOp,e,e)
+    createBinOp :: BinOp -> Ty -> Ty -> Ty -> e -> e -> t -> e
+    createUnOp  :: UnOp -> Ty -> Ty -> e -> t -> e
+    fromUnOp :: e -> Maybe (UnOp,Ty,Ty,e,t)
+    fromBinOp :: e -> Maybe (BinOp,Ty,Ty,Ty,e,e,t)
hunk ./C/OpEval.hs 19
+    fromUnOp _ = Nothing
hunk ./C/OpEval.hs 36
-convOp U2U t1 t2 | t2 `tyLt` t1 = Just Lobits
-convOp I2I t1 t2 | t2 `tyLt` t1 = Just Lobits
-convOp U2U t1 t2 | t2 `tyGt` t1 = Just Zx
-convOp I2I t1 t2 | t2 `tyGt` t1 = Just Sx
+convOp U2U t1 t2 | t2 `tyLte` t1 = Just Lobits
+convOp I2I t1 t2 | t2 `tyLte` t1 = Just Lobits
+convOp U2U t1 t2 | t1 `tyLte` t2 = Just Zx
+convOp I2I t1 t2 | t1 `tyLte` t2 = Just Sx
hunk ./C/OpEval.hs 50
-binOp :: Expression t e => BinOp -> e -> e -> Maybe e
+binOp :: Expression t e => BinOp -> Ty -> Ty -> Ty -> e -> e -> t -> Maybe e
hunk ./C/OpEval.hs 52
-binOp bop e1 e2 | Just (v1,t1) <- toConstant e1, Just (v2,t2) <- toConstant e2 = f bop t1 v1 v2 where
-    f Add t v1 v2 = return $ toExpression (v1 + v2) t
-    f Sub t v1 v2 = return $ toExpression (v1 - v2) t
-    f Mul t v1 v2 = return $ toExpression (v1 * v2) t
-    f Div t v1 v2 | v2 /= 0 = return $ toExpression (v1 `div` v2) t
-    f Mod t v1 v2 | v2 /= 0 = return $ toExpression (v1 `mod` v2) t
-    f Quot t v1 v2 | v2 /= 0 = return $ toExpression (v1 `quot` v2) t
-    f Rem t v1 v2 | v2 /= 0 = return $ toExpression (v1 `rem` v2) t
-    f UDiv t v1 v2 | v2 /= 0 = return $ toExpression (v1 `div` v2) t
-    f UMod t v1 v2 | v2 /= 0 = return $ toExpression (v1 `mod` v2) t
-    f Eq t v1 v2 | v2 /= 0 = return $ toBool (v1 == v2)
-    f NEq t v1 v2 | v2 /= 0 = return $ toBool (v1 /= v2)
-    f _ _ _ _ =  Nothing
+binOp bop t1 t2 tr e1 e2 str | Just (v1,t1) <- toConstant e1, Just (v2,t2) <- toConstant e2 = f bop v1 v2 where
+    f Add v1 v2 = return $ toExpression (v1 + v2) str
+    f Sub v1 v2 = return $ toExpression (v1 - v2) str
+    f Mul v1 v2 = return $ toExpression (v1 * v2) str
+    f Div v1 v2 | v2 /= 0 = return $ toExpression (v1 `div` v2) str
+    f Mod v1 v2 | v2 /= 0 = return $ toExpression (v1 `mod` v2) str
+    f Quot v1 v2 | v2 /= 0 = return $ toExpression (v1 `quot` v2) str
+    f Rem v1 v2 | v2 /= 0 = return $ toExpression (v1 `rem` v2) str
+    f UDiv v1 v2 | v2 /= 0 = return $ toExpression (v1 `div` v2) str
+    f UMod v1 v2 | v2 /= 0 = return $ toExpression (v1 `mod` v2) str
+    f Eq v1 v2 | v2 /= 0 = return $ toBool (v1 == v2)
+    f NEq v1 v2 | v2 /= 0 = return $ toBool (v1 /= v2)
+    f op v1 v2 | Just v <- lookup op ops = return $ toBool (v1 `v` v2) where
+        ops = [(Lt,(<)), (Gt,(>)), (Lte,(<=)), (Gte,(>=)),
+               (FLt,(<)), (FGt,(>)), (FLte,(<=)), (FGte,(>=))]
+    f op v1 v2 | Just v <- lookup op ops, v1 >= 0 && v2 >= 0 = return $ toBool (v1 `v` v2) where
+        ops = [(ULt,(<)), (UGt,(>)), (ULte,(<=)), (UGte,(>=))]
+    f _ _ _ =  Nothing
hunk ./C/OpEval.hs 71
-binOp bop e1 e2 | Just _ <- toConstant e2, Just bop' <- commuteBinOp bop = binOp bop' e2 e1 `mplus` Just (createBinOp bop e2 e1)
-binOp Add e1 e2 | Just (0,_) <- toConstant e1 = return e2
-binOp Sub e1 e2 | Just (0,_) <- toConstant e2 = return e1
-binOp Mul e1 e2 | Just (0,t1) <- toConstant e1 = return $ toExpression 0 t1
-binOp Div e1 e2 | Just (1,_) <- toConstant e2 = return e1
-binOp UDiv e1 e2 | Just (1,_) <- toConstant e2 = return e1
-binOp Quot e1 e2 | Just (1,_) <- toConstant e2 = return e1
-binOp bop e1 e2 = return $ createBinOp bop e1 e2
+binOp bop t1 t2 tr e1 e2 str | Just _ <- toConstant e2, Just bop' <- commuteBinOp bop = binOp bop' t2 t1 tr e2 e1 str `mplus` Just (createBinOp bop' t2 t1 tr e2 e1 str)
+binOp bop t1 t2 tr e1 e2 str = f bop e1 e2 where
+    f Shr e1 e2 | Just (0,_) <- toConstant e2 = return e1
+    f Shra e1 e2 | Just (0,_) <- toConstant e2 = return e1
+    f Shl e1 e2 | Just (0,_) <- toConstant e2 = return e1
+    f Rotl e1 e2 | Just (0,_) <- toConstant e2 = return e1
+    f Rotr e1 e2 | Just (0,_) <- toConstant e2 = return e1
hunk ./C/OpEval.hs 79
+    f Add e1 e2 | Just (0,_) <- toConstant e1 = return e2
+    f Sub e1 e2 | Just (0,_) <- toConstant e2 = return e1
+    f Mul e1 e2 | Just (0,t1) <- toConstant e1 = return $ toExpression 0 str
+    f Mul e1 e2 | Just (1,_) <- toConstant e1 = return e2
+    f Div e1 e2 | Just (1,_) <- toConstant e2 = return e1
+    f Mod e1 e2 | Just (1,_) <- toConstant e2 = return  $ toExpression 0 str
+    f UDiv e1 e2 | Just (1,_) <- toConstant e2 = return e1
+    f UMod e1 e2 | Just (1,_) <- toConstant e2 = return $ toExpression 0 str
+    f Quot e1 e2 | Just (1,_) <- toConstant e2 = return e1
+    f Rem e1 e2 | Just (1,_) <- toConstant e2 = return  $ toExpression 0 str
+    f UGt e1 _ | Just (0,_) <- toConstant e1 = return $ toBool False
+    f ULte e1 _ | Just (0,_) <- toConstant e1 = return $ toBool True
+--    f bop e1 e2 | isAssociative bop, Just (bop',t1',t2',tr',e1',e2',str') <- fromBinOp e1, bop == bop' = let
+--        g binop = binop bop e1' (binop
+--        in g binOp `mplus` g (Just . createBinOp)
+    f bop e1 e2 = Nothing -- return $ createBinOp bop t1 t2 tr e1 e2 str
hunk ./C/OpEval.hs 96
+{-
+unOp :: Expression t e => UnOp -> Ty -> Ty -> e -> t -> Maybe e
+-- evaluate expressions at compile time if we can
+binOp bop t1 t2 tr e1 e2 str | Just (v1,t1) <- toConstant e1, Just (v2,t2) <- toConstant e2 = f bop v1 v2 where
+    f Add v1 v2 = return $ toExpression (v1 + v2) str
+    f Sub v1 v2 = return $ toExpression (v1 - v2) str
+    f Mul v1 v2 = return $ toExpression (v1 * v2) str
+    f Div v1 v2 | v2 /= 0 = return $ toExpression (v1 `div` v2) str
+    f Mod v1 v2 | v2 /= 0 = return $ toExpression (v1 `mod` v2) str
+    f Quot v1 v2 | v2 /= 0 = return $ toExpression (v1 `quot` v2) str
+    f Rem v1 v2 | v2 /= 0 = return $ toExpression (v1 `rem` v2) str
+    f UDiv v1 v2 | v2 /= 0 = return $ toExpression (v1 `div` v2) str
+    f UMod v1 v2 | v2 /= 0 = return $ toExpression (v1 `mod` v2) str
+    f Eq v1 v2 | v2 /= 0 = return $ toBool (v1 == v2)
+    f NEq v1 v2 | v2 /= 0 = return $ toBool (v1 /= v2)
+    f _ _ _ =  Nothing
+-- we normalize ops such that constants are always on the left side
+binOp bop t1 t2 tr e1 e2 str | Just _ <- toConstant e2, Just bop' <- commuteBinOp bop = binOp bop' t2 t1 tr e2 e1 str `mplus` Just (createBinOp bop t2 t1 tr e2 e1 str)
+binOp bop t1 t2 tr e1 e2 str = f bop e1 e2 where
+    f Add e1 e2 | Just (0,_) <- toConstant e1 = return e2
+    f Sub e1 e2 | Just (0,_) <- toConstant e2 = return e1
+    f Mul e1 e2 | Just (0,t1) <- toConstant e1 = return $ toExpression 0 str
+    f Div e1 e2 | Just (1,_) <- toConstant e2 = return e1
+    f UDiv e1 e2 | Just (1,_) <- toConstant e2 = return e1
+    f Quot e1 e2 | Just (1,_) <- toConstant e2 = return e1
+    f bop e1 e2 = return $ createBinOp bop t1 t2 tr e1 e2 str
+  -}
hunk ./E/PrimOpt.hs 64
-    let --primopt (Op (Op.BinOp bop _ _) _) [e1,e2] rt = binOp bop e1 e2
+    let primopt (Op (Op.BinOp bop t1 t2) tr) [e1,e2] rt = binOp bop t1 t2 tr e1 e2 rt
hunk ./E/PrimOpt.hs 78
---instance Expression t E where
---    toBool True = ELit lTruezh
---    toBool False = ELit lFalse
---    createBinOp bop e1 e2 =
---                (EPrim (APrim Op { primCOp = Op.BinOp cop (stringToOpTy ta) (stringToOpTy tb), primRetTy = (stringToOpTy tr) } mempty) [pa, pb] str) t
+instance Expression E E where
+    toBool True = ELit lTruezh
+    toBool False = ELit lFalsezh
+    toConstant (ELit (LitInt n t)) = return (n,t)
+    toConstant _ = Nothing
+    toExpression n t = (ELit (LitInt n t))
+    createBinOp bop t1 t2 tr e1 e2 str =
+                EPrim (APrim Op { primCOp = Op.BinOp bop t1 t2, primRetTy = tr } mempty) [e1, e2] str
+    createUnOp bop t1 tr e1 str =
+                EPrim (APrim Op { primCOp = Op.UnOp bop t1, primRetTy = tr } mempty) [e1] str
+    fromBinOp (EPrim (APrim Op { primCOp = Op.BinOp bop t1 t2, primRetTy = tr } mempty) [e1, e2] str) = Just (bop,t1,t2,tr,e1,e2,str)
+    fromBinOp _ = Nothing
+    fromUnOp (EPrim (APrim Op { primCOp = Op.UnOp bop t1, primRetTy = tr } mempty) [e1] str) = Just (bop,t1,tr,e1,str)
+    fromUnOp _ = Nothing