const-math-ghc-plugin (empty) → 0.1.0.0
raw patch · 7 files changed
+431/−0 lines, 7 filesdep +basedep +containersdep +ghcsetup-changed
Dependencies added: base, containers, ghc
Files
- ConstMath/Pass.hs +260/−0
- ConstMath/Plugin.hs +32/−0
- ConstMath/Rules.hs +43/−0
- ConstMath/Types.hs +33/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- const-math-ghc-plugin.cabal +31/−0
+ ConstMath/Pass.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}++{-# OPTIONS_GHC -Wall #-}+module ConstMath.Pass (+ constMathProgram+) where++import ConstMath.Types++import Control.Applicative ((<$>))+import Control.Monad ((<=<))+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe++import GhcPlugins++constMathProgram :: Opts -> [CoreBind] -> CoreM [CoreBind]+constMathProgram opts binds = do+ traceMsg opts "\nStarting ConstMath pass"+ mapM (subBind opts "") binds++subBind :: Opts -> String -> CoreBind -> CoreM CoreBind+subBind opts tab (NonRec b rhs) = do+ traceMsg opts $ tab ++ "Non-recursive binding named " ++ showSDoc (ppr b)+ rhs' <- subExpr opts tab rhs+ return (NonRec b rhs')+subBind opts _tab bndr@(Rec pairs) = do+ _ <- mapM (uncurry $ printRecBind opts) pairs+ return bndr++printRecBind opts b _e = do+ traceMsg opts $ "Recursive binding " ++ showSDoc (ppr b)++subExpr :: Opts -> String -> CoreExpr -> CoreM CoreExpr++subExpr opts tab expr@(Type t) = do+ traceMsg opts $ tab ++ "Type " ++ showSDoc (ppr t)+ return expr++subExpr opts tab expr@(Coercion _co) = do+ traceMsg opts $ tab ++ "Coercion"+ return expr++subExpr opts tab expr@(Lit lit) = do+ traceMsg opts $ tab ++ "Lit " ++ showSDoc (ppr lit)+ return expr++subExpr opts tab expr@(Var v) = do+ traceMsg opts $ tab ++ "Var " ++ showSDoc (ppr v)+ return expr++subExpr opts tab (App f a) = do+ traceMsg opts $ tab ++ "App " ++ showSDoc (ppr f)+ f' <- subExpr opts (tab ++ "< ") f+ a' <- subExpr opts (tab ++ "> ") a+ collapse opts (App f' a')++subExpr opts tab (Tick t e) = do+ traceMsg opts $ tab ++ "Tick"+ e' <- subExpr opts (tab ++ " ") e+ return (Tick t e')++subExpr opts tab (Cast e co) = do+ traceMsg opts $ tab ++ "Cast"+ e' <- subExpr opts (tab ++ " ") e+ return (Cast e' co)++subExpr opts tab (Lam b e) = do+ traceMsg opts $ tab ++ "Lam"+ e' <- subExpr opts (tab ++ " ") e+ return (Lam b e')++subExpr opts tab (Let bind e) = do+ traceMsg opts $ tab ++ "Let"+ bind' <- subBind opts tab bind+ e' <- subExpr opts (tab ++ " ") e+ return (Let bind' e')++subExpr opts tab (Case scrut bndr ty alts) = do+ traceMsg opts $ tab ++ "Case"+ let subAlt (ac,bs,eB) = (ac,bs,) <$> subExpr opts (tab ++ " ") eB+ scrut' <- subExpr opts (tab ++ " ") scrut+ alts' <- mapM subAlt alts+ return (Case scrut' bndr ty alts')++----------------------------------------------------------------------++collapse :: Opts -> CoreExpr -> CoreM CoreExpr+collapse opts expr@(App f1 _)+ | Just f <- cmSubst <$> findSub f1+ = f opts expr+collapse _ expr = return expr++mkUnaryCollapseIEEE :: (forall a. RealFloat a => (a -> a))+ -> Opts+ -> CoreExpr+ -> CoreM CoreExpr+mkUnaryCollapseIEEE fnE opts expr@(App f1 (App f2 (Lit lit)))+ | isDHash f2, MachDouble d <- lit = evalUnaryIEEE d mkDoubleLitDouble+ | isFHash f2, MachFloat d <- lit = evalUnaryIEEE d mkFloatLitFloat+ where+ evalUnaryIEEE d mkLit = do+ let sub = fnE (fromRational d)+ maybe (return expr)+ (return . App f2 . mkLit)+ =<< maybeIEEE opts (fromJust $ funcName f1) sub+mkUnaryCollapseIEEE _ _ expr = return expr++mkUnaryCollapseNum :: (forall a . Num a => (a -> a))+ -> Opts+ -> CoreExpr+ -> CoreM CoreExpr+mkUnaryCollapseNum fnE _opts (App _f1 (App f2 (Lit lit)))+ | isDHash f2, MachDouble d <- lit =+ evalUnaryNum fromRational d mkDoubleLitDouble+ | isFHash f2, MachFloat d <- lit =+ evalUnaryNum fromRational d mkFloatLitFloat+ | isIHash f2, MachInt d <- lit =+ evalUnaryNum fromIntegral d mkIntLitInt+ | isWHash f2, MachWord d <- lit =+ evalUnaryNum fromIntegral d mkWordLitWord+ where+ evalUnaryNum from d mkLit = do+ let sub = fnE (from d)+ return (App f2 (mkLit sub))+mkUnaryCollapseNum _ _ expr = return expr++mkBinaryCollapse :: (forall a. RealFloat a => (a -> a -> a))+ -> Opts+ -> CoreExpr+ -> CoreM CoreExpr+mkBinaryCollapse fnE opts expr@(App (App f1 (App f2 (Lit lit1))) (App f3 (Lit lit2)))+ | isDHash f2 && isDHash f3+ , MachDouble d1 <- lit1, MachDouble d2 <- lit2 =+ evalBinaryIEEE d1 d2 mkDoubleLitDouble+ | isFHash f2 && isFHash f3+ , MachFloat d1 <- lit1, MachFloat d2 <- lit2 =+ evalBinaryIEEE d1 d2 mkFloatLitFloat+ where+ evalBinaryIEEE d1 d2 mkLit = do+ let sub = fnE (fromRational d1) (fromRational d2)+ maybe (return expr) (\x -> return (App f2 (mkLit x)))+ =<< maybeIEEE opts (fromJust $ funcName f1) sub+mkBinaryCollapse _ _ expr = return expr++fromRationalCollapse :: Opts -> CoreExpr -> CoreM CoreExpr+fromRationalCollapse opts expr@(App f1 (App (App f2 (Lit (LitInteger n _))) (Lit (LitInteger d _))))+ | Just "ConstMath.Rules.rationalToFloat" <- funcName f1+ , Just "GHC.Real.:%" <- funcName f2+ = do+ let sub = fromRational $ (fromInteger n) / (fromInteger d)+ maybe (return expr) (\x -> return (mkFloatExpr x)) =<< maybeIEEE opts (fromJust $ funcName f1) sub+fromRationalCollapse opts expr@(App f1 (App (App f2 (Lit (LitInteger n _))) (Lit (LitInteger d _))))+ | Just "ConstMath.Rules.rationalToDouble" <- funcName f1+ , Just "GHC.Real.:%" <- funcName f2+ = do+ let sub = fromRational $ (fromInteger n) / (fromInteger d)+ maybe (return expr) (\x -> return (mkDoubleExpr x)) =<< maybeIEEE opts (fromJust $ funcName f1) sub+fromRationalCollapse _ expr = return expr++maybeIEEE :: RealFloat a => Opts -> String -> a -> CoreM (Maybe a)+maybeIEEE opts s d+ | isNaN d = do+ err "NaN"+ return Nothing+ | isInfinite d = do+ err "infinite"+ return Nothing+ | isDenormalized d = do+ err "denormalized"+ return Nothing+ | isNegativeZero d = do+ err "negative zero"+ return Nothing+ | otherwise = do+ msg opts $ "Result of replacing " ++ s ++ " is ok"+ return (Just d)+ where+ err v = errorMsgS $ "Skipping replacement of " ++ s ++ " result " ++ v++----------------------------------------------------------------------++data CMSub = CMSub+ { cmFuncName :: String+ , cmSubst :: Opts -> CoreExpr -> CoreM CoreExpr+ }++unarySubIEEE :: String -> (forall a. RealFloat a => a -> a) -> CMSub+unarySubIEEE nm fn = CMSub nm (mkUnaryCollapseIEEE fn)++unarySubNum :: String -> (forall a . Num a => (a -> a)) -> CMSub+unarySubNum nm fn = CMSub nm (mkUnaryCollapseNum fn)++binarySub :: String -> (forall a. RealFloat a => a -> a -> a) -> CMSub+binarySub nm fn = CMSub nm (mkBinaryCollapse fn)++funcName :: CoreExpr -> Maybe String+funcName = listToMaybe . words . showSDoc . ppr++isFHash :: CoreExpr -> Bool+isFHash = maybe False ((==) "GHC.Types.F#") . funcName++isDHash :: CoreExpr -> Bool+isDHash = maybe False ((==) "GHC.Types.D#") . funcName++isIHash :: CoreExpr -> Bool+isIHash = maybe False ((==) "GHC.Types.I#") . funcName++isWHash :: CoreExpr -> Bool+isWHash = maybe False ((==) "GHC.Word.W#") . funcName++findSub :: CoreExpr -> Maybe CMSub+findSub = flip Map.lookup subFunc <=< funcName++subs :: [CMSub]+subs =+ [ unarySubIEEE "GHC.Float.exp" exp+ , unarySubIEEE "GHC.Float.log" log+ , unarySubIEEE "GHC.Float.sqrt" sqrt+ , unarySubIEEE "GHC.Float.sin" sin+ , unarySubIEEE "GHC.Float.cos" cos+ , unarySubIEEE "GHC.Float.tan" tan+ , unarySubIEEE "GHC.Float.asin" asin+ , unarySubIEEE "GHC.Float.acos" acos+ , unarySubIEEE "GHC.Float.atan" atan+ , unarySubIEEE "GHC.Float.sinh" sinh+ , unarySubIEEE "GHC.Float.cosh" cosh+ , unarySubIEEE "GHC.Float.tanh" tanh+ , unarySubIEEE "GHC.Float.asinh" asinh+ , unarySubIEEE "GHC.Float.acosh" acosh+ , unarySubIEEE "GHC.Float.atanh" atanh+ , unarySubNum "GHC.Num.negate" negate+ , unarySubNum "GHC.Num.abs" abs+ , unarySubNum "GHC.Num.signum" signum+ , CMSub "ConstMath.Rules.rationalToFloat" fromRationalCollapse+ , CMSub "ConstMath.Rules.rationalToDouble" fromRationalCollapse+ ]++subFunc :: Map String CMSub+subFunc = Map.fromList $ zip (map cmFuncName subs) subs++----------------------------------------------------------------------++msg :: Opts -> String -> CoreM ()+msg opts s+ | not (quiet opts) = putMsgS s+ | otherwise = return ()++vMsg :: Opts -> String -> CoreM ()+vMsg opts s+ | verbose opts = putMsgS s+ | otherwise = return ()++traceMsg :: Opts -> String -> CoreM ()+traceMsg opts s+ | traced opts = putMsgS s+ | otherwise = return ()
+ ConstMath/Plugin.hs view
@@ -0,0 +1,32 @@+module ConstMath.Plugin (+ plugin -- :: Plugin+) where++import ConstMath.Types+import ConstMath.Pass (constMathProgram)+import GhcPlugins++import Data.List (intersperse)++plugin :: Plugin+plugin = defaultPlugin {+ installCoreToDos = install+ }++install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]+install args todos = do+ reinitializeGlobals+ let pass = CoreDoPasses [constMath]+ return $ intersperse pass todos+ where constMath = CoreDoPluginPass "Constant Math Elimination"+ (bindsOnlyPass (constMathProgram (parseOpts args)) )++-- TODO: use a real parser+parseOpts :: [CommandLineOption] -> Opts+parseOpts = foldr ($) defaultOpts . map mkArg+ where+ mkArg flag+ | flag `elem` ["-v","--verbose","--verbosity=1"] = setVerbosity (CmVerbose 1)+ | flag `elem` ["-v11", "-verbosity=11","--trace"] = setVerbosity Trace+ | flag `elem` ["-q", "--quiet","--verbosity=0", "-v0"] = setVerbosity None+ | otherwise = id
+ ConstMath/Rules.hs view
@@ -0,0 +1,43 @@+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK hide #-}++module ConstMath.Rules (+ rationalToFloat+, rationalToDouble+) where++import GHC.Float+import GHC.Real++rationalToFloat :: Rational -> Float+rationalToFloat (n:%0)+ | n == 0 = 0/0+ | n < 0 = (-1)/0+ | otherwise = 1/0+rationalToFloat (n:%d)+ | n == 0 = encodeFloat 0 0+ | n < 0 = -(fromRat'' minEx mantDigs (-n) d)+ | otherwise = fromRat'' minEx mantDigs n d+ where+ minEx = fst (floatRange (0::Float))+ mantDigs = floatDigits (0 :: Float)+{-# NOINLINE [1] rationalToFloat #-}++rationalToDouble :: Rational -> Double+rationalToDouble (n:%0)+ | n == 0 = 0/0+ | n < 0 = (-1)/0+ | otherwise = 1/0+rationalToDouble (n:%d)+ | n == 0 = encodeFloat 0 0+ | n < 0 = -(fromRat'' minEx mantDigs (-n) d)+ | otherwise = fromRat'' minEx mantDigs n d+ where+ minEx = fst (floatRange (0 :: Double))+ mantDigs = floatDigits (0 :: Double)+{-# NOINLINE [1] rationalToDouble #-}++{-# RULES+"ConstMath/rationalToFloat" fromRational = rationalToFloat+"ConstMath/rationalToDouble" fromRational = rationalToDouble+ #-}
+ ConstMath/Types.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE NamedFieldPuns #-}++{-# OPTIONS_GHC -Wall #-}+module ConstMath.Types (+ Opts(..)+, Verbosity(..)+, defaultOpts+, setVerbosity+, quiet+, verbose+, traced+) where++data Verbosity = None | CmVerbose Int | Trace deriving (Eq, Show, Ord)++data Opts = Opts+ { cmVerbosity :: Verbosity }+ deriving (Eq, Show)++setVerbosity :: Verbosity -> Opts -> Opts+setVerbosity cmVerbosity opts = Opts{cmVerbosity}++defaultOpts :: Opts+defaultOpts = Opts None++quiet :: Opts -> Bool+quiet Opts{cmVerbosity} = cmVerbosity == None++verbose :: Opts -> Bool+verbose Opts{cmVerbosity} = cmVerbosity > CmVerbose 0++traced :: Opts -> Bool+traced Opts{cmVerbosity} = cmVerbosity >= Trace
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Conrad Parker++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Conrad Parker nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ const-math-ghc-plugin.cabal view
@@ -0,0 +1,31 @@+name: const-math-ghc-plugin+version: 0.1.0.0+synopsis: Compiler plugin for constant math elimination+description: + This library implements elimination of constant math expressions.+license: BSD3+license-file: LICENSE+author: Conrad Parker, John Lato+maintainer: Conrad Parker <conrad@metadecks.org>+-- copyright: +category: Compiler Plugin+build-type: Simple+cabal-version: >=1.8++library+ exposed-modules: ConstMath.Plugin+ ConstMath.Rules+ other-modules: ConstMath.Pass+ ConstMath.Types+ build-depends: base < 5,+ containers,+ ghc >= 7.4++------------------------------------------------------------------------+-- Git repo+--+source-repository head+ type: git+ location: git://github.com/kfish/const-math-ghc-plugin.git++