diff --git a/HerbiePlugin.cabal b/HerbiePlugin.cabal --- a/HerbiePlugin.cabal +++ b/HerbiePlugin.cabal @@ -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 diff --git a/src/Herbie.hs b/src/Herbie.hs --- a/src/Herbie.hs +++ b/src/Herbie.hs @@ -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) diff --git a/src/Herbie/CoreManip.hs b/src/Herbie/CoreManip.hs --- a/src/Herbie/CoreManip.hs +++ b/src/Herbie/CoreManip.hs @@ -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 diff --git a/src/Herbie/ForeignInterface.hs b/src/Herbie/ForeignInterface.hs --- a/src/Herbie/ForeignInterface.hs +++ b/src/Herbie/ForeignInterface.hs @@ -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 diff --git a/src/Herbie/MathExpr.hs b/src/Herbie/MathExpr.hs --- a/src/Herbie/MathExpr.hs +++ b/src/Herbie/MathExpr.hs @@ -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 diff --git a/src/Herbie/MathInfo.hs b/src/Herbie/MathInfo.hs --- a/src/Herbie/MathInfo.hs +++ b/src/Herbie/MathInfo.hs @@ -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 diff --git a/src/Herbie/Options.hs b/src/Herbie/Options.hs new file mode 100644 --- /dev/null +++ b/src/Herbie/Options.hs @@ -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 diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/test/ValidRewrite.hs b/test/ValidRewrite.hs new file mode 100644 --- /dev/null +++ b/test/ValidRewrite.hs @@ -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" + + + + +