HerbiePlugin 0.1.0.0 → 0.2.0.0
raw patch · 9 files changed
+238/−59 lines, 9 filesdep +lineardep +splitdep ~base
Dependencies added: linear, split
Dependency ranges changed: base
Files
- HerbiePlugin.cabal +22/−2
- src/Herbie.hs +39/−15
- src/Herbie/CoreManip.hs +17/−17
- src/Herbie/ForeignInterface.hs +11/−14
- src/Herbie/MathExpr.hs +9/−6
- src/Herbie/MathInfo.hs +5/−5
- src/Herbie/Options.hs +35/−0
- test/Tests.hs +14/−0
- test/ValidRewrite.hs +86/−0
HerbiePlugin.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.1.0.0+version: 0.2.0.0 -- A short (one-line) description of the package. synopsis: automatically improve your code's numeric stability@@ -72,6 +72,7 @@ Herbie.ForeignInterface Herbie.MathExpr Herbie.MathInfo+ Herbie.Options Show Paths_HerbiePlugin @@ -81,6 +82,8 @@ ScopedTypeVariables DeriveGeneric DeriveAnyClass+ DeriveDataTypeable+ StandaloneDeriving -- Other library packages from which modules are imported. build-depends: base >=4.8 && <4.9@@ -92,6 +95,7 @@ , directory , deepseq , mtl+ , split -- Directories containing source files. hs-source-dirs: src@@ -107,8 +111,24 @@ ghc-options: -fplugin=Herbie--- -dcore-lint build-depends:+ base, subhask, HerbiePlugin++Test-Suite ValidRewrite+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: ValidRewrite.hs++ ghc-options:+ -fplugin=Herbie+ -fplugin-opts=Herbie:tol=0++ build-depends:+ base,+ subhask,+ HerbiePlugin,+ linear
src/Herbie.hs view
@@ -18,12 +18,15 @@ import Control.Monad import Control.Monad.Except+import Data.Data import Data.Maybe+import Data.Typeable import Herbie.CoreManip import Herbie.ForeignInterface import Herbie.MathExpr import Herbie.MathInfo+import Herbie.Options import Debug.Trace @@ -59,9 +62,14 @@ -- ++ showSDoc dflags (ppr $ varType b) -- putMsgS $ myshow dflags e -- return bndr- e' <- go [] e+ anns <- annotationsOn guts b :: CoreM [String]+ e' <- if "NoHerbie" `elem` anns+ then return e+ else go [] e return $ NonRec b e' where+ pluginOpts = parsePluginOpts opts+ -- Recursively descend into the expression e. -- For each math expression we find, run Herbie on it. -- We need to save each dictionary we find because@@ -120,7 +128,7 @@ cond' <- go dicts cond es' <- forM es $ \ (altcon, xs, expr) -> do expr' <- go dicts expr- return $ (altcon, xs, expr')+ return (altcon, xs, expr') return $ Case cond' w t es' -- Ticks and Casts are just annotating extra information on an expression.@@ -155,20 +163,29 @@ } res <- liftIO $ stabilizeMathExpr dbgInfo $ getMathExpr mathInfo let mathInfo' = mathInfo { getMathExpr = cmdout res }- putMsgS $ " improved expression = "++pprMathInfo mathInfo'- putMsgS $ " original error = "++show (errin res)++" bits"- putMsgS $ " improved error = "++show (errout res)++" bits"- ret <- runExceptT $ mathInfo2expr guts mathInfo'- case ret of- Left str -> do- putMsgS " WARNING: Not substituting the improved expression into your code"- putMsgS str- return e- Right e' -> do--- putMsgS $ " before = " ++ myshow dflags e--- putMsgS $ " after = " ++ myshow dflags e'- return e' + -- Display the improved expression if found+ let canRewrite = True -- errin res-errout res > optsTol pluginOpts+ if canRewrite+ then do+ putMsgS $ " improved expression = "++pprMathInfo mathInfo'+ putMsgS $ " original error = "++show (errin res)++" bits"+ putMsgS $ " improved error = "++show (errout res)++" bits"+ else do+ putMsgS $ " Herbie could not improve the stability of the original expression"++ -- Rewrite the expression+ if not (optsRewrite pluginOpts) || not canRewrite+ then return e+ else do+ ret <- runExceptT $ mathInfo2expr guts mathInfo'+ case ret of+ Left str -> do+ putMsgS " WARNING: Not substituting the improved expression into your code"+ putMsgS str+ return e+ Right e' -> return e'+ -- | Return a list with the given variable if the variable is a dictionary or tuple of dictionaries, -- otherwise return []. extractDicts :: Var -> [Var]@@ -183,3 +200,10 @@ undeadenId a = if isDeadBinder a then setIdOccInfo a NoOccInfo else a++-- | Function taken from the docs:+-- https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/compiler-plugins.html+annotationsOn :: Data a => ModGuts -> CoreBndr -> CoreM [a]+annotationsOn guts bndr = do+ anns <- getAnnotations deserializeWithData guts+ return $ lookupWithDefaultUFM anns [] (varUnique bndr)
src/Herbie/CoreManip.hs view
@@ -61,11 +61,11 @@ where getName :: ModGuts -> String -> Name getName guts str = case filter isCorrectVar (concat $ occEnvElts (mg_rdr_env guts)) of- xs -> if length xs>0- then gre_name $ head $ xs+ xs -> if not (null xs)+ then gre_name $ head xs else error $ "getName: '"++str++"'" where- isCorrectVar x = (getString $ gre_name x) == str+ isCorrectVar x = getString (gre_name x) == str && (str == "abs" || case gre_par x of NoParent -> False; _ -> True) -- | Like "decorateFunction", but first finds the function variable given a string.@@ -100,13 +100,13 @@ getDictionary guts dictTy = do let dictVar = mkGlobalVar VanillaId- (mkSystemName (mkUnique 'z' 1337) (mkVarOcc $ "magicDictionaryName"))+ (mkSystemName (mkUnique 'z' 1337) (mkVarOcc "magicDictionaryName")) dictTy vanillaIdInfo bnds <- lift $ runTcM guts $ do loc <- getCtLoc $ GivenOrigin UnkSkol- let nonC = mkNonCanonical $ CtWanted+ let nonC = mkNonCanonical CtWanted { ctev_pred = varType dictVar , ctev_evar = dictVar , ctev_loc = loc@@ -163,7 +163,7 @@ IrredPred _ -> go exprs EqPred _ t1 t2 -> trace ("getPredEvidence.go.EP: pred="++dbg pred- ++"; origType="++dbg (baseTy)+ ++"; origType="++dbg baseTy ++"; exprType="++dbg (exprType expr) ) $ case splitAppTy_maybe pred of Nothing -> trace " A" $ go exprs@@ -183,7 +183,7 @@ -- -- FIXME: Multiparamter classes broken ClassPred c' [ct] -> trace ("getPredEvidence.go.CP: pred="++dbg pred- ++"; origType="++dbg (baseTy)+ ++"; origType="++dbg baseTy ++"; exprType="++dbg (exprType expr) ) $ go $@@ -200,7 +200,7 @@ -- For each field of the tuple we extract it with a case statement, then recurse. TuplePred preds -> do trace ("getPredEvidence.go.TP: pred="++dbg pred- ++"; origType="++dbg (baseTy)+ ++"; origType="++dbg baseTy ++"; exprType="++dbg (exprType expr) ) $ return () @@ -218,7 +218,7 @@ ] uniq <- getUniqueM- let wildName = mkSystemName uniq (mkVarOcc $ "wild")+ let wildName = mkSystemName uniq (mkVarOcc "wild") wildVar = mkLocalVar VanillaId wildName (exprType expr) vanillaIdInfo let ret =@@ -260,7 +260,7 @@ IrredPred _ -> go exprs EqPred _ t1 t2 -> trace ("castToType.go.EP: castTy="++dbg castTy- ++"; origType="++dbg (baseTy)+ ++"; origType="++dbg baseTy ++"; exprType="++dbg (exprType expr) ) $ goEqPred [] castTy (exprType inputExpr) where@@ -293,7 +293,7 @@ mkCast :: Bool -> ExceptT String CoreM CoreExpr mkCast isFlipped = do coboxUniq <- getUniqueM- let coboxName = mkSystemName coboxUniq (mkVarOcc $ "cobox")+ let coboxName = mkSystemName coboxUniq (mkVarOcc "cobox") coboxType = if isFlipped then mkCoercionType Nominal castTyRHS inputTyRHS else mkCoercionType Nominal inputTyRHS castTyRHS@@ -306,7 +306,7 @@ mkCoercion (x:xs) = mkTyConAppCo Nominal x [mkCoercion xs] wildUniq <- getUniqueM- let wildName = mkSystemName wildUniq (mkVarOcc $ "wild")+ let wildName = mkSystemName wildUniq (mkVarOcc "wild") wildType = exprType expr wildVar = mkLocalVar VanillaId wildName wildType vanillaIdInfo @@ -319,7 +319,7 @@ , Cast inputExpr $ mkSubCo $ mkCoercion tyCons ) ] - -- | FIXME: ClassPred and TuplePred are both handled the same+ -- FIXME: ClassPred and TuplePred are both handled the same -- within castToPred and getPredEvidence. -- They should be factored out? ClassPred c' [ct] -> go $@@ -345,7 +345,7 @@ ] uniq <- getUniqueM- let wildName = mkSystemName uniq (mkVarOcc $ "wild")+ let wildName = mkSystemName uniq (mkVarOcc "wild") wildVar = mkLocalVar VanillaId wildName (exprType expr) vanillaIdInfo let ret =@@ -416,7 +416,7 @@ extractContext :: Type -> ([Type],Type) extractContext t = case splitTyConApp_maybe t of Nothing -> ([],t)- Just (tycon,xs) -> if (occNameString $ nameOccName $ tyConName tycon)/="(->)"+ Just (tycon,xs) -> if occNameString (nameOccName $ tyConName tycon) /= "(->)" || not hasCxt then ([],t) else (head xs:cxt',t')@@ -433,7 +433,7 @@ extractParam :: Type -> Maybe Type extractParam t = case splitTyConApp_maybe t of Nothing -> Nothing- Just (tycon,xs) -> if (occNameString $ nameOccName $ tyConName tycon)/="(->)"+ Just (tycon,xs) -> if occNameString (nameOccName $ tyConName tycon) /= "(->)" then Just t -- Nothing else Just (head xs) @@ -483,7 +483,7 @@ getString = occNameString . getOccName expr2str :: DynFlags -> Expr Var -> String-expr2str dflags (Var v) = {-"var_" ++-} var2str v+expr2str dflags (Var v) = {-"var_" ++-} var2str v++"_"++showSDoc dflags (ppr $ getUnique v) expr2str dflags e = "expr_" ++ (decorate $ showSDoc dflags (ppr e)) where decorate :: String -> String
src/Herbie/ForeignInterface.hs view
@@ -29,7 +29,7 @@ stabilizeMathExpr dbgInfo cmdin = do let (cmdinLisp,varmap) = getCanonicalLispCmd $ haskellOpsToHerbieOps cmdin res <- stabilizeLisp dbgInfo cmdinLisp- cmdout <- do+ cmdout' <- do -- FIXME: -- Due to a bug in Herbie, fromCanonicalLispCmd sometimes throws an exception. ret <- try $ do@@ -42,11 +42,11 @@ Right x -> return x let res' = res { cmdin = cmdin- , cmdout = cmdout+ , cmdout = cmdout' }--- putStrLn $ "cmdin: "++cmdinLisp--- putStrLn $ "cmdout: "++cmdout res--- putStrLn $ "stabilizeLisp': "++mathExpr2lisp (fromCanonicalLispCmd (cmdout res,varmap))+-- putStrLn $ " cmdin: "++cmdinLisp+-- putStrLn $ " cmdout: "++cmdout res+-- putStrLn $ " stabilizeLisp': "++mathExpr2lisp (fromCanonicalLispCmd (cmdout res,varmap)) return res' -- | Given a Lisp command, return a numerically stable version.@@ -77,7 +77,7 @@ execHerbie lisp = do -- build the command string we will pass to Herbie- let varstr = "("++(intercalate " " $ lisp2vars lisp)++")"+ let varstr = "("++unwords (lisp2vars lisp)++")" stdin = "(herbie-test "++varstr++" \"cmd\" "++lisp++") \n" -- Herbie can take a long time to run.@@ -101,21 +101,18 @@ { errin = read $ drop 1- $ dropWhile (/=':')- $ line1+ $ dropWhile (/=':') line1 , errout = read $ drop 1- $ dropWhile (/=':')- $ line2+ $ dropWhile (/=':') line2 , cmdin = lisp , cmdout = (!!2) $ groupByParens $ init- $ tail- $ line3+ $ tail line3 } deepseq ret $ return ret @@ -124,7 +121,7 @@ putStrLn $ "WARNING in execHerbie: "++show e putStrLn $ "WARNING in execHerbie: stdin="++stdin putStrLn $ "WARNING in execHerbie: stdout="++stdout- return $ StabilizerResult+ return StabilizerResult { errin = 0/0 , errout = 0/0 , cmdin = lisp@@ -237,7 +234,7 @@ res <- queryNamed conn "SELECT id,cmdout from StabilizerResults where cmdin = :cmdin"- [":cmdin" := (cmdin res)]+ [":cmdin" := cmdin res] :: IO [(Int,String)] execute conn "INSERT INTO DbgInfo (resid,dbgComments,modName,functionName,functionType) VALUES (?,?,?,?,?)" (fst $ head res,dbgComments dbgInfo,modName dbgInfo,functionName dbgInfo,functionType dbgInfo) close conn
src/Herbie/MathExpr.hs view
@@ -4,6 +4,7 @@ import Control.DeepSeq import Data.List+import Data.List.Split import Data.Maybe import GHC.Generics @@ -196,9 +197,11 @@ ["if",cond,e1,e2] -> EIf (lisp2mathExpr cond) (lisp2mathExpr e1) (lisp2mathExpr e2) _ -> error $ "lisp2mathExpr: "++xs else error $ "lisp2mathExpr: malformed input '("++xs++"'"-lisp2mathExpr xs = case readMaybe xs :: Maybe Double of- Just x -> ELit $ toRational x- Nothing -> ELeaf xs+lisp2mathExpr xs = case splitOn "/" xs of+ [num,den] -> lisp2mathExpr $ "(/ "++num++" "++den++")"+ _ -> case readMaybe xs :: Maybe Double of+ Just x -> ELit $ toRational x+ Nothing -> ELeaf xs -- | Extracts all the variables from the lisp commands with no duplicates. lisp2vars :: String -> [String]@@ -211,9 +214,9 @@ = sort $ filter (\x -> x/="(" && x/=")"- && not (x `elem` binOpList)- && not (x `elem` monOpList)- && not (head x `elem` ("1234567890"::String))+ && (x `notElem` binOpList)+ && (x `notElem` monOpList)+ && (head x `notElem` ("1234567890"::String)) ) $ tokenize lisp :: [String] where
src/Herbie/MathInfo.hs view
@@ -73,7 +73,7 @@ else str where str = case e of- EMonOp op e1 -> op++" "++(go i True e1)+ EMonOp op e1 -> op++" "++ go i True e1 EBinOp op e1 e2 -> go i parens1 e1++" "++op++" "++go i parens2 e2 where@@ -136,13 +136,13 @@ Just t -> if mathExprDepth getMathExpr>1 && lispHasRepeatVars (mathExpr2lisp getMathExpr) then Just $ MathInfo getMathExpr- ( ParamType+ ParamType { getQuantifier = quantifier , getCxt = cxt , getDicts = map Var dicts , getParam = t }- ) exprs+ exprs else Nothing where@@ -229,7 +229,7 @@ a2' <- go a2 wildUniq <- getUniqueM- let wildName = mkSystemName wildUniq (mkVarOcc $ "wild")+ let wildName = mkSystemName wildUniq (mkVarOcc "wild") wildVar = mkLocalVar VanillaId wildName boolTy vanillaIdInfo return $ Case@@ -249,7 +249,7 @@ ratioTyCon <- lookupTyCon ratioTyConName tmpUniq <- getUniqueM- let tmpName = mkSystemName tmpUniq (mkVarOcc $ "a")+ let tmpName = mkSystemName tmpUniq (mkVarOcc "a") tmpVar = mkTyVar tmpName liftedTypeKind tmpVarT = mkTyVarTy tmpVar ratioConTy = mkForAllTy tmpVar $ mkFunTys [tmpVarT,tmpVarT] $ mkAppTy (mkTyConTy ratioTyCon) tmpVarT
+ src/Herbie/Options.hs view
@@ -0,0 +1,35 @@+-- | This module handles parsing the options that can get passed into the HerbiePlugin+module Herbie.Options+ where++import GhcPlugins++data PluginOpts = PluginOpts+ {+ -- | This comment will be stored in the Herbie database for each expression that is found+ optsComments :: String++ -- | Controls whether rewriting is enabled or not+ , optsRewrite :: Bool++ -- | Perform the rewrite only if the improved expression reduces instability+ -- by this number of bits+ , optsTol :: Double+ }++defPluginOpts :: PluginOpts+defPluginOpts = PluginOpts+ { optsComments = ""+ , optsRewrite = True+ , optsTol = 0.5+ }++parsePluginOpts :: [CommandLineOption] -> PluginOpts+parsePluginOpts xs = go xs defPluginOpts+ where+ go [] opts = opts+ go (x:xs) opts+ | take 9 x == "noRewrite" = go xs $ opts { optsRewrite = False }+ | take 4 x == "tol=" = go xs $ opts { optsTol = read (drop 4 x) }+ | take 8 x == "comment=" = go xs $ opts { optsComments = drop 8 x }+ | otherwise = go xs opts
test/Tests.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE GADTs,RebindableSyntax,CPP,FlexibleContexts,FlexibleInstances,ConstraintKinds #-}++{-# GHC-OPTS -dcore-lint #-}+ {- - The idea of this test suite is that it should be compiled - with the -fplugin=Herbie and -dcore-lint flags.@@ -9,6 +12,17 @@ where import SubHask++--------------------------------------------------------------------------------++-- This section tests that Herbie obeys the code annotations++{-# ANN ann "NoHerbie" #-}+ann :: Float -> Float+ann x = x+x+x*x*x*x++noann :: Float -> Float+noann x = x+x+x*x*x*x --------------------------------------------------------------------------------
+ test/ValidRewrite.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE GADTs,RebindableSyntax,CPP,FlexibleContexts,FlexibleInstances,ConstraintKinds #-}+{-# LANGUAGE StandaloneDeriving,DeriveDataTypeable #-}+{-+ - This test suite ensures that the rewrites that HerbiePlugin performs+ - give the correct results.+ -}++module Main+ where++import SubHask+import System.IO+import Linear.Quaternion+import Linear.V3+import Linear.Vector++--------------------------------------------------------------------------------++test1a :: Double -> Double -> Double+test1a far near = -(2 * far * near) / (far - near)++{-# ANN test1b "NoHerbie" #-}+test1b :: Double -> Double -> Double+test1b far near = -(2 * far * near) / (far - near)++{-# ANN test1c "NoHerbie" #-}+test1c :: Double -> Double -> Double+test1c far near = -(if far < (negate 1.7210442634149447e81)+ then (far / (far - near)) * 2 * near+ else if far < 8.364504563556443e16+ then (far * 2) / (far - near) / near+ else (far / (far - near)) * 2 * near)++--------------------++test2a :: Double -> Double -> Double+test2a a b = a + ((b - a) / 2)++{-# ANN test2b "NoHerbie" #-}+test2b :: Double -> Double -> Double+test2b a b = a + ((b - a) / 2)++--------------------++test3a :: Quaternion Double -> Quaternion Double -> Quaternion Double+test3a (Quaternion q0 (V3 q1 q2 q3)) (Quaternion r0 (V3 r1 r2 r3)) =+ Quaternion (r0*q0+r1*q1+r2*q2+r3*q3)+ (V3 (r0*q1-r1*q0-r2*q3+r3*q2)+ (r0*q2+r1*q3-r2*q0-r3*q1)+ (r0*q3-r1*q2+r2*q1-r3*q0))+ ^/ (r0*r0 + r1*r1 + r2*r2 + r3*r3)++{-# ANN test3b "NoHerbie" #-}+test3b :: Quaternion Double -> Quaternion Double -> Quaternion Double+test3b (Quaternion q0 (V3 q1 q2 q3)) (Quaternion r0 (V3 r1 r2 r3)) =+ Quaternion (r0*q0+r1*q1+r2*q2+r3*q3)+ (V3 (r0*q1-r1*q0-r2*q3+r3*q2)+ (r0*q2+r1*q3-r2*q0-r3*q1)+ (r0*q3-r1*q2+r2*q1-r3*q0))+ ^/ (r0*r0 + r1*r1 + r2*r2 + r3*r3)++--------------------------------------------------------------------------------++#define mkTest(f1,f2,a,b) \+ putStrLn $ "mkTest: " ++ show (f1 (a) (b)); \+ putStrLn $ "mkTest: " ++ show (f2 (a) (b)); \+ putStrLn ""++main = do+ mkTest(test1a,test1b,-2e90,6)+ mkTest(test1a,test1b,0,6)+ mkTest(test1a,test1b,2e90,6)++ mkTest(test1a,test1c,-2e90,6)+ mkTest(test1a,test1c,0,6)+ mkTest(test1a,test1c,2e90,6)++ mkTest(test2a,test2b,1,2)++ mkTest(test3a,test3b,(Quaternion 1 (V3 1 2 3)),(Quaternion 2 (V3 2 3 4)))+ putStrLn "done"+++++