From 07c43547dd86be9cea4dd7038844eca59daf5349 Mon Sep 17 00:00:00 2001 From: anabra Date: Mon, 17 Feb 2020 00:37:08 +0100 Subject: [PATCH 01/11] ES: added Pipeline/Eval --- grin/grin.cabal | 1 + grin/src/Pipeline/ExtendedSyntax/Eval.hs | 46 ++++++++++++++++++++++++ 2 files changed, 47 insertions(+) create mode 100644 grin/src/Pipeline/ExtendedSyntax/Eval.hs diff --git a/grin/grin.cabal b/grin/grin.cabal index c9045f36..4fb6ef5b 100644 --- a/grin/grin.cabal +++ b/grin/grin.cabal @@ -115,6 +115,7 @@ library Grin.ExtendedSyntax.TypeEnv Grin.ExtendedSyntax.TypeEnvDefs Grin.ExtendedSyntax.GADT + Pipeline.ExtendedSyntax.Eval Pipeline.Eval Pipeline.Optimizations Pipeline.Pipeline diff --git a/grin/src/Pipeline/ExtendedSyntax/Eval.hs b/grin/src/Pipeline/ExtendedSyntax/Eval.hs new file mode 100644 index 00000000..b743ae65 --- /dev/null +++ b/grin/src/Pipeline/ExtendedSyntax/Eval.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} +module Pipeline.ExtendedSyntax.Eval where + +import qualified Data.Text.IO as Text +import Text.Megaparsec + +import Grin.ExtendedSyntax.Grin +import Grin.ExtendedSyntax.TypeCheck +import Grin.ExtendedSyntax.Parse +import Reducer.ExtendedSyntax.Base (RTVal) +import qualified Reducer.ExtendedSyntax.IO as ReducerIO +import qualified Reducer.ExtendedSyntax.Pure as ReducerPure +import qualified Reducer.ExtendedSyntax.LLVM.JIT as LLVM +import qualified Reducer.ExtendedSyntax.LLVM.CodeGen as LLVM +import qualified AbstractInterpretation.ExtendedSyntax.HeapPointsTo.CodeGen as HPT +import qualified AbstractInterpretation.ExtendedSyntax.HeapPointsTo.Result as HPT +import AbstractInterpretation.ExtendedSyntax.Reduce (AbstractInterpretationResult(..), evalAbstractProgram) + + + +data Reducer + = PureReducer + | IOReducer + | LLVMReducer + deriving (Eq, Show) + +-- TODO: Add Mode as a parameter? +eval' :: Reducer -> String -> IO RTVal +eval' reducer fname = do + content <- Text.readFile fname + case parseGrin fname content of + Left err -> error $ parseErrorPretty' content err + Right program -> + case reducer of + PureReducer -> ReducerPure.reduceFun program "grinMain" + IOReducer -> ReducerIO.reduceFun program "grinMain" + LLVMReducer -> LLVM.eagerJit (LLVM.codeGen typeEnv program) "grinMain" where + typeEnv = either error id $ typeEnvFromHPTResult hptResult + hptResult = HPT.toHPTResult hptMapping ((_airComp . evalAbstractProgram) $ hptProgram) + (hptProgram, hptMapping) = HPT.codeGen program + +evalProgram :: Reducer -> Program -> IO RTVal +evalProgram reducer program = + case reducer of + PureReducer -> ReducerPure.reduceFun program "grinMain" + IOReducer -> ReducerIO.reduceFun program "grinMain" From c73ec64d14b08aff7f03e44ba985eb19c0b21e67 Mon Sep 17 00:00:00 2001 From: anabra Date: Mon, 17 Feb 2020 00:44:02 +0100 Subject: [PATCH 02/11] ES: added Pipeline/Optimizations --- grin/grin.cabal | 1 + .../Pipeline/ExtendedSyntax/Optimizations.hs | 39 +++++++++++++++++++ 2 files changed, 40 insertions(+) create mode 100644 grin/src/Pipeline/ExtendedSyntax/Optimizations.hs diff --git a/grin/grin.cabal b/grin/grin.cabal index 4fb6ef5b..b387e460 100644 --- a/grin/grin.cabal +++ b/grin/grin.cabal @@ -116,6 +116,7 @@ library Grin.ExtendedSyntax.TypeEnvDefs Grin.ExtendedSyntax.GADT Pipeline.ExtendedSyntax.Eval + Pipeline.ExtendedSyntax.Optimizations Pipeline.Eval Pipeline.Optimizations Pipeline.Pipeline diff --git a/grin/src/Pipeline/ExtendedSyntax/Optimizations.hs b/grin/src/Pipeline/ExtendedSyntax/Optimizations.hs new file mode 100644 index 00000000..3c61dadc --- /dev/null +++ b/grin/src/Pipeline/ExtendedSyntax/Optimizations.hs @@ -0,0 +1,39 @@ +module Pipeline.ExtendedSyntax.Optimizations + ( evaluatedCaseElimination + , trivialCaseElimination + , sparseCaseOptimisation + , copyPropagation + , constantPropagation + , interproceduralDeadDataElimination + , interproceduralDeadFunctionElimination + , interproceduralDeadParameterElimination + , deadFunctionElimination + , deadVariableElimination + , deadParameterElimination + , commonSubExpressionElimination + , caseCopyPropagation + , generalizedUnboxing + , arityRaising + , caseHoisting + , lateInlining + , nonSharedElimination + ) where + +import Transformations.ExtendedSyntax.Optimising.EvaluatedCaseElimination (evaluatedCaseElimination) +import Transformations.ExtendedSyntax.Optimising.TrivialCaseElimination (trivialCaseElimination) +import Transformations.ExtendedSyntax.Optimising.SparseCaseOptimisation (sparseCaseOptimisation) +import Transformations.ExtendedSyntax.Optimising.CopyPropagation (copyPropagation) +import Transformations.ExtendedSyntax.Optimising.ConstantPropagation (constantPropagation) +import Transformations.ExtendedSyntax.Optimising.InterproceduralDeadDataElimination (interproceduralDeadDataElimination) +import Transformations.ExtendedSyntax.Optimising.InterproceduralDeadFunctionElimination (interproceduralDeadFunctionElimination) +import Transformations.ExtendedSyntax.Optimising.InterproceduralDeadParameterElimination (interproceduralDeadParameterElimination) +import Transformations.ExtendedSyntax.Optimising.DeadFunctionElimination (deadFunctionElimination) +import Transformations.ExtendedSyntax.Optimising.DeadVariableElimination (deadVariableElimination) +import Transformations.ExtendedSyntax.Optimising.DeadParameterElimination (deadParameterElimination) +import Transformations.ExtendedSyntax.Optimising.CSE (commonSubExpressionElimination) +import Transformations.ExtendedSyntax.Optimising.CaseCopyPropagation (caseCopyPropagation) +import Transformations.ExtendedSyntax.Optimising.GeneralizedUnboxing (generalizedUnboxing) +import Transformations.ExtendedSyntax.Optimising.ArityRaising (arityRaising) +import Transformations.ExtendedSyntax.Optimising.CaseHoisting (caseHoisting) +import Transformations.ExtendedSyntax.Optimising.Inlining (lateInlining) +import Transformations.ExtendedSyntax.Optimising.NonSharedElimination (nonSharedElimination) From 1d99bb91c0599e2e31469f934993776ffdcaf8ca Mon Sep 17 00:00:00 2001 From: anabra Date: Mon, 17 Feb 2020 00:45:37 +0100 Subject: [PATCH 03/11] ES: added Pipeline/Pipeline --- grin/grin.cabal | 1 + grin/src/Pipeline/ExtendedSyntax/Pipeline.hs | 1192 ++++++++++++++++++ 2 files changed, 1193 insertions(+) create mode 100644 grin/src/Pipeline/ExtendedSyntax/Pipeline.hs diff --git a/grin/grin.cabal b/grin/grin.cabal index b387e460..88b661c0 100644 --- a/grin/grin.cabal +++ b/grin/grin.cabal @@ -117,6 +117,7 @@ library Grin.ExtendedSyntax.GADT Pipeline.ExtendedSyntax.Eval Pipeline.ExtendedSyntax.Optimizations + Pipeline.ExtendedSyntax.Pipeline Pipeline.Eval Pipeline.Optimizations Pipeline.Pipeline diff --git a/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs b/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs new file mode 100644 index 00000000..3dbcd190 --- /dev/null +++ b/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs @@ -0,0 +1,1192 @@ +{-# LANGUAGE LambdaCase, RecordWildCards, RankNTypes, PatternSynonyms, TemplateHaskell #-} +module Pipeline.ExtendedSyntax.Pipeline + ( PipelineOpts(..) + , defaultOpts + , PipelineStep(..) + , AbstractComputationStep(..) + , Transformation(..) + , EffectStep(..) + , Path(..) + , RenderingOption(..) + , pattern HPTPass + , pattern PrintGrin + , pattern SimplePrintGrin + , pattern FullPrintGrin + , pattern DeadCodeElimination + , pipeline + , optimize + , optimizeWith + , randomPipeline + ) where + +import Prelude +import Control.Monad +import Data.Text (Text) +import Data.Maybe (maybe, fromJust, fromMaybe) +import Text.Printf +import Text.Pretty.Simple (pPrint) +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (), (<$$>)) +import qualified Text.Show.Pretty as PP + +import Pipeline.Eval +import Grin.Grin +import Grin.TypeEnv +import Grin.TypeCheck +import Grin.EffectMap hiding (Eff) +import Pipeline.Optimizations +import qualified Grin.Statistics as Statistics +import Grin.Parse +import Grin.Pretty(showWide, prettyProgram, RenderingOption(..)) +import Transformations.CountVariableUse +import Transformations.GenerateEval +import qualified Transformations.Simplifying.Vectorisation2 as Vectorisation2 +import Transformations.Simplifying.Vectorisation +import Transformations.BindNormalisation +import qualified Grin.Lint as Lint +import Grin.PrettyLint +import Transformations.Simplifying.SplitFetch +import Transformations.Simplifying.BindingPatternSimplification +import Transformations.Simplifying.CaseSimplification +import Transformations.Optimising.Inlining (inlineEval, inlineApply, inlineBuiltins) +import Transformations.UnitPropagation +import Transformations.MangleNames +import Transformations.EffectMap +import Transformations.StaticSingleAssignment +import Transformations.Names (ExpChanges(..)) +import qualified Transformations.Simplifying.RightHoistFetch2 as RHF +import Transformations.Simplifying.RegisterIntroduction +import Transformations.Simplifying.ProducerNameIntroduction +import qualified AbstractInterpretation.HeapPointsTo.Result as HPT +import qualified AbstractInterpretation.CreatedBy.Readback as CBy +import qualified AbstractInterpretation.CreatedBy.Result as CBy +import qualified AbstractInterpretation.LiveVariable.Result as LVA +import qualified AbstractInterpretation.EffectTracking.Result as ET +import qualified AbstractInterpretation.Sharing.Result as Sharing +import AbstractInterpretation.BinaryIR +import AbstractInterpretation.OptimiseAbstractProgram +import AbstractInterpretation.CreatedBy.Pretty +import AbstractInterpretation.HeapPointsTo.Pretty +import AbstractInterpretation.LiveVariable.Pretty +import AbstractInterpretation.EffectTracking.Pretty +import AbstractInterpretation.Sharing.Pretty +import AbstractInterpretation.Sharing.CodeGen +import AbstractInterpretation.Reduce (ComputerState, AbstractInterpretationResult(..), evalAbstractProgram) +import qualified AbstractInterpretation.PrettyIR as IR +import qualified AbstractInterpretation.IR as IR +import qualified AbstractInterpretation.HeapPointsTo.CodeGen as HPT +import qualified AbstractInterpretation.HeapPointsTo.CodeGenBase as HPT +import qualified AbstractInterpretation.CreatedBy.CodeGen as CBy +import qualified AbstractInterpretation.LiveVariable.CodeGen as LVA +import qualified AbstractInterpretation.EffectTracking.CodeGen as ET +import qualified AbstractInterpretation.EffectTracking.CodeGenBase as ET +import qualified AbstractInterpretation.Sharing.CodeGen as Sharing +import qualified Reducer.LLVM.CodeGen as CGLLVM +import qualified Reducer.LLVM.JIT as JITLLVM +import System.Directory +import qualified System.Process +import Data.Bifunctor + +import qualified Data.Bimap as Bimap +import qualified Data.Map as Map +import qualified Data.Set as Set +import LLVM.Pretty (ppllvm) +import qualified Data.Text.Lazy.IO as Text + +import Control.Monad.State.Class as MonadState (get, put, gets) +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict hiding (gets) +import Control.Monad.IO.Class +import Lens.Micro.TH +import Lens.Micro.Mtl +import System.FilePath +import System.Exit +import Control.DeepSeq +import Debug.Trace +import Lens.Micro +import Data.List + +import Data.Algorithm.Diff +import Data.Algorithm.DiffOutput +import Control.Monad.Extra +import System.Random +import Data.Time.Clock +import Data.Fixed +import Data.Functor.Infix +import Data.Maybe (isNothing) +import System.IO (BufferMode(..), hSetBuffering, stdout) +import Data.Binary as Binary +import Grin.Nametable as Nametable +import qualified Data.ByteString.Lazy as LBS + + +data Transformation + -- Simplifying + = RegisterIntroduction + | ProducerNameIntroduction + | BindingPatternSimplification + | Vectorisation + | SplitFetch + | CaseSimplification + | RightHoistFetch + | InlineEval + | InlineApply + | InlineBuiltins + -- Misc + | GenerateEval + | BindNormalisation + | ConstantFolding + | UnitPropagation + | MangleNames + | StaticSingleAssignment + -- Optimizations + | EvaluatedCaseElimination + | TrivialCaseElimination + | SparseCaseOptimisation + | UpdateElimination + | NonSharedElimination + | CopyPropagation + | ConstantPropagation + | DeadDataElimination + | DeadFunctionElimination + | DeadParameterElimination + | DeadVariableElimination + | SimpleDeadFunctionElimination + | SimpleDeadVariableElimination + | SimpleDeadParameterElimination + | CommonSubExpressionElimination + | CaseCopyPropagation + | CaseHoisting + | GeneralizedUnboxing + | ArityRaising + | LateInlining + deriving (Enum, Eq, Ord, Show) + +newtype Hidden a = H a + +instance Show (Hidden a) where + show _ = "(hidden)" + +instance Eq (Hidden a) where + _ == _ = True + +data AbstractComputationStep + = Compile + | Optimise + | PrintProgram + | SaveProgram String + | RunPure + | PrintResult + deriving (Eq, Show) + +data EffectStep + = CalcEffectMap + | PrintEffectMap + deriving (Eq, Show) + +data PipelineStep + = Optimize + | HPT AbstractComputationStep + | CBy AbstractComputationStep + | LVA AbstractComputationStep + | ET AbstractComputationStep + | Sharing AbstractComputationStep + | RunCByWithLVA -- TODO: Remove + | Eff EffectStep + | T Transformation + | Pass [PipelineStep] + | PrintGrinH RenderingOption (Hidden (Doc -> Doc)) + | PureEval + | JITLLVM + | PrintAST + | SaveLLVM Path + | SaveExecutable Bool Path -- Debug, Outputfile + | SaveGrin Path + | SaveBinary String + | DebugTransformationH (Hidden (Exp -> Exp)) + | Statistics + | PrintTypeAnnots + | PrintTypeEnv + | SaveTypeEnv + | Lint + | ConfluenceTest + | PrintErrors + | DebugPipelineState + deriving (Eq, Show) + +pattern DeadCodeElimination :: PipelineStep +pattern DeadCodeElimination = Pass + [ T DeadFunctionElimination + , T DeadDataElimination + , T DeadVariableElimination + , T DeadParameterElimination + ] + +pattern HPTPass :: PipelineStep +pattern HPTPass = Pass + [ HPT Compile + , HPT RunPure + ] + +data Path + = Abs FilePath + | Rel FilePath + deriving (Eq, Show) + +pattern PrintGrin :: RenderingOption -> (Doc -> Doc) -> PipelineStep +pattern PrintGrin r c <- PrintGrinH r (H c) + where PrintGrin r c = PrintGrinH r (H c) + +pattern SimplePrintGrin :: (Doc -> Doc) -> PipelineStep +pattern SimplePrintGrin c <- PrintGrinH Simple (H c) + where SimplePrintGrin c = PrintGrinH Simple (H c) + +pattern FullPrintGrin :: (Doc -> Doc) -> PipelineStep +pattern FullPrintGrin c <- PrintGrinH WithExternals (H c) + where FullPrintGrin c = PrintGrinH WithExternals (H c) + +pattern DebugTransformation :: (Exp -> Exp) -> PipelineStep +pattern DebugTransformation t <- DebugTransformationH (H t) + where DebugTransformation t = DebugTransformationH (H t) + +data PipelineOpts = PipelineOpts + { _poOutputDir :: FilePath + , _poFailOnLint :: Bool + , _poLogging :: Bool + , _poSaveTypeEnv :: Bool + , _poStatistics :: Bool + , _poLintOnChange :: Bool + , _poTypedLint :: Bool -- Run HPT before every lint + , _poSaveBinary :: Bool + } + +defaultOpts :: PipelineOpts +defaultOpts = PipelineOpts + { _poOutputDir = ".grin-output" + , _poFailOnLint = True + , _poLogging = True + , _poSaveTypeEnv = False + , _poStatistics = False + , _poLintOnChange = True + , _poTypedLint = False + , _poSaveBinary = False + } + +type PipelineM a = ReaderT PipelineOpts (StateT PState IO) a +data PState = PState + { _psExp :: Exp + , _psTransStep :: !Int + , _psSaveIdx :: !Int + , _psHPTProgram :: Maybe (IR.AbstractProgram, HPT.HPTMapping) + , _psHPTResult :: Maybe HPT.HPTResult + , _psCByProgram :: Maybe (IR.AbstractProgram, CBy.CByMapping) + , _psCByResult :: Maybe CBy.CByResult + , _psLVAProgram :: Maybe (IR.AbstractProgram, LVA.LVAMapping) + , _psLVAResult :: Maybe LVA.LVAResult + , _psETProgram :: Maybe (IR.AbstractProgram, ET.ETMapping) + , _psETResult :: Maybe ET.ETResult + , _psSharingProgram :: Maybe (IR.AbstractProgram, Sharing.SharingMapping) + , _psSharingResult :: Maybe Sharing.SharingResult + -- the type environment calculated by HPT + , _psTypeEnv :: Maybe TypeEnv + -- the type environment parsed from the source code + , _psTypeAnnots :: TypeEnv + , _psEffectMap :: Maybe EffectMap + , _psErrors :: [String] + , _psIntendation :: Int + } deriving (Show) + +makeLenses ''PState +makeLenses ''PipelineOpts + +data PipelineEff + = None + | ExpChanged + deriving (Eq, Show) + +_None :: Traversal' PipelineEff () +_None f None = const None <$> f () +_None _ rest = pure rest + +_ExpChanged :: Traversal' PipelineEff () +_ExpChanged f ExpChanged = const ExpChanged <$> f () +_ExpChanged _ rest = pure rest + + +-- NOTE: All the return types of the transformations should be the same. +data TransformationFunc + = Plain (Exp -> (Exp, ExpChanges)) + | WithTypeEnv (TypeEnv -> Exp -> Either String (Exp, ExpChanges)) + | WithTypeEnvEff (TypeEnv -> EffectMap -> Exp -> (Exp, ExpChanges)) + | WithTypeEnvShr (Sharing.SharingResult -> TypeEnv -> Exp -> (Exp, ExpChanges)) + | WithLVA (LVA.LVAResult -> TypeEnv -> Exp -> Either String (Exp, ExpChanges)) + | WithLVACBy (LVA.LVAResult -> CBy.CByResult -> TypeEnv -> Exp -> Either String (Exp, ExpChanges)) + +-- TODO: Add n paramter for the transformations that use NameM +transformationFunc :: Int -> Transformation -> TransformationFunc +transformationFunc n = \case + Vectorisation -> WithTypeEnv (newNames <$$> Right <$$> Vectorisation2.vectorisation) + GenerateEval -> Plain generateEval + CaseSimplification -> Plain (noNewNames . caseSimplification) + SplitFetch -> Plain (noNewNames . splitFetch) + RegisterIntroduction -> Plain (newNames . registerIntroductionI n) -- TODO + ProducerNameIntroduction -> Plain producerNameIntroduction + BindingPatternSimplification -> Plain bindingPatternSimplification + RightHoistFetch -> Plain (noNewNames . RHF.rightHoistFetch) + -- misc + MangleNames -> Plain (newNames . mangleNames) -- TODO + StaticSingleAssignment -> Plain (newNames . staticSingleAssignment) -- TODO + BindNormalisation -> Plain (noNewNames . bindNormalisation) + ConstantFolding -> Plain (newNames . constantFolding) + -- optimising + EvaluatedCaseElimination -> Plain (noNewNames . evaluatedCaseElimination) + TrivialCaseElimination -> Plain (noNewNames . trivialCaseElimination) + UpdateElimination -> Plain (noNewNames . updateElimination) + CopyPropagation -> Plain (noNewNames . copyPropagation) -- TODO + ConstantPropagation -> Plain (noNewNames . constantPropagation) -- TODO + SimpleDeadFunctionElimination -> Plain (noNewNames . simpleDeadFunctionElimination) + SimpleDeadParameterElimination -> Plain (noNewNames . simpleDeadParameterElimination) + SimpleDeadVariableElimination -> WithTypeEnvEff (noNewNames <$$$> simpleDeadVariableElimination) + InlineEval -> WithTypeEnv (Right <$$> inlineEval) + InlineApply -> WithTypeEnv (Right <$$> inlineApply) + InlineBuiltins -> WithTypeEnv (Right <$$> inlineBuiltins) + CommonSubExpressionElimination -> WithTypeEnvEff (noNewNames <$$$> commonSubExpressionElimination) + CaseCopyPropagation -> Plain caseCopyPropagation + CaseHoisting -> WithTypeEnv (Right <$$> caseHoisting) + GeneralizedUnboxing -> WithTypeEnv (Right <$$> generalizedUnboxing) + ArityRaising -> WithTypeEnv (Right <$$> (arityRaising n)) + LateInlining -> WithTypeEnv (Right <$$> lateInlining) + UnitPropagation -> WithTypeEnv (noNewNames <$$> Right <$$> unitPropagation) + NonSharedElimination -> WithTypeEnvShr nonSharedElimination + DeadFunctionElimination -> WithLVA (noNewNames <$$$$> deadFunctionElimination) + DeadVariableElimination -> WithLVA (noNewNames <$$$$> deadVariableElimination) + DeadParameterElimination -> WithLVA (noNewNames <$$$$> deadParameterElimination) + DeadDataElimination -> WithLVACBy deadDataElimination + SparseCaseOptimisation -> WithTypeEnv (noNewNames <$$$> sparseCaseOptimisation) + where + noNewNames = flip (,) NoChange + newNames = flip (,) NewNames + +transformation :: Transformation -> PipelineM () +transformation t = do + runAnalysisFor t + n <- use psTransStep + e <- use psExp + te <- fromMaybe (traceShow "empty type env is used" emptyTypeEnv) <$> use psTypeEnv + em <- fromMaybe (traceShow "empty effect map is used" mempty) <$> use psEffectMap + et <- fromMaybe (traceShow "empty effect tracking result is used" mempty) <$> use psETResult + cby <- fromMaybe (traceShow "empty created by result is used" CBy.emptyCByResult) <$> use psCByResult + lva <- fromMaybe (traceShow "empty live variable result is used" LVA.emptyLVAResult) <$> use psLVAResult + shr <- fromMaybe (traceShow "empty sharing result is used" Sharing.emptySharingResult) <$> use psSharingResult + either (\e -> psErrors %= (e:)) onExp $ + case transformationFunc n t of + Plain f -> Right $ f e + WithTypeEnv f -> f te e + WithTypeEnvEff f -> Right $ f te em e + WithLVA f -> f lva te e + WithLVACBy f -> f lva cby te e + WithTypeEnvShr f -> Right $ f shr te e + psTransStep %= (+1) + where + onExp (e, changes) = do + psExp .= e + when (changes /= NoChange) invalidateAnalysisResults + +pipelineStep :: PipelineStep -> PipelineM PipelineEff +pipelineStep p = do + inceaseIntendation + i <- use psIntendation + case p of + Pass{} -> pipelineLog "Pass" + _ | isPrintingStep p -> pipelineLog $ printf ("PipelineStep: %-" ++ show (80 - 2 * i) ++ "s") (show p) + _ -> pipelineLogNoLn $ printf ("PipelineStep: %-" ++ show (80 - 2 * i) ++ "s") (show p) + before <- use psExp + start <- liftIO getCurrentTime + case p of + Optimize -> optimizeWithM [] defaultOptimizations [] + + HPT step -> case step of + Compile -> compileAbstractProgram HPT.codeGen psHPTProgram + Optimise -> optimiseAbsProgWith psHPTProgram "HPT program is not available to be optimized" + PrintProgram -> printAbstractProgram psHPTProgram + SaveProgram p -> saveAbstractProgram p psHPTProgram + RunPure -> runHPTPure + PrintResult -> printAnalysisResult psHPTResult + + CBy step -> case step of + Compile -> compileAbstractProgram CBy.codeGen psCByProgram + Optimise -> optimiseAbsProgWith psCByProgram "CBy program is not available to be optimized" + PrintProgram -> printAbstractProgram psCByProgram + SaveProgram p -> saveAbstractProgram p psCByProgram + RunPure -> runCByPure + PrintResult -> printAnalysisResult psCByResult + + LVA step -> case step of + Compile -> compileAbstractProgram LVA.codeGen psLVAProgram + Optimise -> optimiseAbsProgWith psLVAProgram "LVA program is not available to be optimized" + PrintProgram -> printAbstractProgram psLVAProgram + SaveProgram p -> saveAbstractProgram p psLVAProgram + RunPure -> runLVAPure + PrintResult -> printAnalysisResult psLVAResult + + ET step -> case step of + Compile -> compileAbstractProgram ET.codeGen psETProgram + Optimise -> optimiseAbsProgWith psETProgram "ET program is not available to be optimized" + PrintProgram -> printAbstractProgram psETProgram + RunPure -> runETPure + PrintResult -> printAnalysisResult psETResult + + RunCByWithLVA -> runCByWithLVAPure + + Sharing step -> case step of + Compile -> compileAbstractProgram Sharing.codeGen psSharingProgram + Optimise -> optimiseAbsProgWith psSharingProgram "Sharing program is not available to be optimized" + PrintProgram -> printAbstractProgram psSharingProgram + SaveProgram p -> saveAbstractProgram p psSharingProgram + RunPure -> runSharingPure + PrintResult -> printAnalysisResult psSharingResult + + Eff eff -> case eff of + CalcEffectMap -> calcEffectMap + PrintEffectMap -> printEffectMap + T t -> transformation t + Pass pass -> mapM_ pipelineStep pass + PrintGrin r d -> printGrinM r d + PureEval -> pureEval + JITLLVM -> jitLLVM + SaveLLVM path -> saveLLVM path + SaveExecutable dbg path -> saveExecutable dbg path + SaveGrin path -> saveGrin path + SaveBinary name -> saveBinary name + PrintAST -> printAST + PrintTypeAnnots -> printTypeAnnots + PrintTypeEnv -> printTypeEnv + SaveTypeEnv -> saveTypeEnv + DebugTransformation t -> debugTransformation t + Statistics -> statistics + Lint -> lintGrin Nothing + ConfluenceTest -> confluenceTest + PrintErrors -> do + errors <- use psErrors + pipelineLog $ unlines $ "errors:" : errors + DebugPipelineState -> debugPipelineState + after <- use psExp + let eff = if before == after then None else ExpChanged + showMS :: Rational -> String + showMS t = printf "%.6f ms" (realToFrac $ 1E3 * t :: Double) + + end <- liftIO getCurrentTime + case p of + Pass{} -> pure () + T{} -> pipelineLog $ printf "had effect: %s (%s)" + (show eff) (showMS $ toRational $ diffUTCTime end start) + _ -> pipelineLog $ printf "(%s)" (showMS $ toRational $ diffUTCTime end start) + when (eff == ExpChanged) $ psSaveIdx %= succ + -- TODO: Test this only for development mode. + decreateIntendation + return eff + + +calcEffectMap :: PipelineM () +calcEffectMap = do + grin <- use psExp + env0 <- fromMaybe (traceShow "Empty type environment is used to calculate effect map" emptyTypeEnv) <$> use psTypeEnv + psEffectMap .= Just (effectMap (env0, grin)) + +printEffectMap :: PipelineM () +printEffectMap = do + effs <- fromMaybe (traceShow "No effect map is available" mempty) <$> use psEffectMap + pipelineLog $ show $ pretty effs + +optimiseAbsProgWith :: Lens' PState (Maybe (IR.AbstractProgram, a)) -> String -> PipelineM () +optimiseAbsProgWith getProg err = do + mProg <- use getProg + case mProg of + Just prog -> getProg . _Just . _1 %= optimiseAbstractProgram + Nothing -> pipelineLog err + +compileAbstractProgram :: (Exp -> prog) -> (Lens' PState (Maybe prog)) -> PipelineM () +compileAbstractProgram codeGen accessProg = do + grin <- use psExp + accessProg .= Just (codeGen grin) + +printAbsProg :: IR.AbstractProgram -> PipelineM () +printAbsProg a = do + pipelineLog $ show $ IR.prettyInstructions Nothing . IR._absInstructions $ a + pipelineLog $ printf "memory size %d" $ IR._absMemoryCounter a + pipelineLog $ printf "register count %d" $ IR._absRegisterCounter a + -- TODO: pass mapping + --pipelineLog $ printf "variable count %d" $ Map.size $ IR._absRegisterMap a + +printAbstractProgram :: (Lens' PState (Maybe (IR.AbstractProgram, a))) -> PipelineM () +printAbstractProgram accessProg = do + progM <- use accessProg + mapM_ (printAbsProg . fst) progM + +saveAbstractProgram :: String -> (Lens' PState (Maybe (IR.AbstractProgram, a))) -> PipelineM () +saveAbstractProgram name accessProg = do + progM <- use accessProg + n <- use psSaveIdx + case progM of + Nothing -> pure () + Just (prog, mapping) -> do + outputDir <- view poOutputDir + let fname = printf "%03d.%s.dfbin" n name + liftIO $ LBS.writeFile (outputDir fname) $ encodeAbstractProgram prog + +printAnalysisResult :: Pretty res => (Lens' PState (Maybe res)) -> PipelineM () +printAnalysisResult accessRes = use accessRes >>= \case + Nothing -> pure () + Just result -> pipelineLog $ show $ pretty result + + +runHPTPure :: PipelineM () +runHPTPure = use psHPTProgram >>= \case + Nothing -> psHPTResult .= Nothing + Just (hptProgram, hptMapping) -> do + let AbsIntResult{..} = evalAbstractProgram hptProgram + result = HPT.toHPTResult hptMapping _airComp + pipelineLogIterations _airIter + psHPTResult .= Just result + case typeEnvFromHPTResult result of + Right te -> psTypeEnv .= Just te + Left err -> do + psErrors %= (err :) + liftIO $ printf "type-env error: %s" err + psTypeEnv .= Nothing + + +runCByPureWith :: (CBy.CByMapping -> ComputerState -> CBy.CByResult) -> PipelineM () +runCByPureWith toCByResult = use psCByProgram >>= \case + Nothing -> psCByResult .= Nothing + Just (cbyProgram, cbyMapping) -> do + let AbsIntResult{..} = evalAbstractProgram cbyProgram + result = toCByResult cbyMapping _airComp + pipelineLogIterations _airIter + psCByResult .= Just result + case typeEnvFromHPTResult (CBy._hptResult result) of + Right te -> psTypeEnv .= Just te + Left err -> do + psErrors %= (err :) + psTypeEnv .= Nothing + +runCByPure :: PipelineM () +runCByPure = runCByPureWith CBy.toCByResult + +runCByWithLVAPure :: PipelineM () +runCByWithLVAPure = do + runLVAPure + use psLVAResult >>= \case + Nothing -> do + psCByResult .= Nothing + psErrors %= ("LVA result is not availabe for cby-with-lva pass" :) + Just lvaResult -> runCByPureWith (CBy.toCByResultWithLiveness lvaResult) + + +runLVAPure :: PipelineM () +runLVAPure = use psLVAProgram >>= \case + Nothing -> psLVAResult .= Nothing + Just (lvaProgram, lvaMapping) -> do + let AbsIntResult{..} = evalAbstractProgram $ lvaProgram + result = LVA.toLVAResult lvaMapping _airComp + pipelineLogIterations _airIter + psLVAResult .= Just result + +runETPure :: PipelineM () +runETPure = use psETProgram >>= \case + Nothing -> psETResult .= Nothing + Just (etProgram, etMapping) -> do + let AbsIntResult{..} = evalAbstractProgram $ etProgram + result = ET.toETResult etMapping _airComp + pipelineLogIterations _airIter + psETResult .= Just result + +runSharingPureWith :: (Sharing.SharingMapping -> ComputerState -> Sharing.SharingResult) -> PipelineM () +runSharingPureWith toSharingResult = use psSharingProgram >>= \case + Nothing -> psSharingResult .= Nothing + Just (shrProgram, shrMapping) -> do + let AbsIntResult{..} = evalAbstractProgram shrProgram + result = toSharingResult shrMapping _airComp + pipelineLogIterations _airIter + psSharingResult .= Just result + case typeEnvFromHPTResult (Sharing._hptResult result) of + Right te -> psTypeEnv .= Just te + Left err -> do + psErrors %= (err :) + psTypeEnv .= Nothing + +runSharingPure :: PipelineM () +runSharingPure = runSharingPureWith Sharing.toSharingResult + + +printTypeAnnots :: PipelineM () +printTypeAnnots = do + typeEnv <- use psTypeAnnots + pipelineLog . show . pretty $ typeEnv + +printTypeEnv :: PipelineM () +printTypeEnv = do + Just typeEnv <- use psTypeEnv + pipelineLog . show . pretty $ typeEnv + + +saveTransformationInfo :: (Pretty a) => String -> a -> PipelineM () +saveTransformationInfo name content = do + n <- use psSaveIdx + outputDir <- view poOutputDir + let fname = printf "%03d.%s" n name + liftIO $ do + writeFile (outputDir fname) $ showWide $ plain $ pretty content + +saveTypeEnv :: PipelineM () +saveTypeEnv = do + mTypeEnv <- use psTypeEnv + forM_ mTypeEnv $ saveTransformationInfo "Type-Env" + mHPTResult <- use psHPTResult + forM_ mHPTResult $ saveTransformationInfo "HPT-Result" + +statistics :: PipelineM () +statistics = do + exp <- use psExp + saveTransformationInfo "Statistics" $ Statistics.statistics exp + +pureEval :: PipelineM () +pureEval = do + e <- use psExp + val <- liftIO $ do + hSetBuffering stdout NoBuffering + evalProgram PureReducer e + pipelineLog $ show $ pretty val + +printGrinM :: RenderingOption -> (Doc -> Doc) -> PipelineM () +printGrinM r color = do + p <- use psExp + pipelineLog $ showWide $ color $ prettyProgram r p + +jitLLVM :: PipelineM () +jitLLVM = do + e <- use psExp + Just typeEnv <- use psTypeEnv + val <- liftIO $ JITLLVM.eagerJit (CGLLVM.codeGen typeEnv e) "grinMain" + pipelineLog $ show $ pretty val + +printAST :: PipelineM () +printAST = do + e <- use psExp + pPrint e + +saveGrin :: Path -> PipelineM () +saveGrin path = do + e <- use psExp + case path of + Rel fn -> saveTransformationInfo fn e + Abs fn -> liftIO $ do + writeFile fn $ show $ plain $ pretty e + +-- | Save binary similar as transformation info. +saveBinary :: String -> PipelineM () +saveBinary name = do + n <- use psSaveIdx + ent <- Nametable.convert <$> use psExp + outputDir <- view poOutputDir + let fname = printf "%03d.%s.binary" n name + liftIO $ Binary.encodeFile (outputDir fname) ent + +relPath :: Path -> PipelineM String +relPath path = do + n <- use psSaveIdx + o <- view poOutputDir + pure $ case path of + Abs fname -> fname + Rel fname -> o printf "%03d.%s" n fname + +callCommand :: String -> PipelineM () +callCommand cmd = do + pipelineLog $ "Call command:" ++ cmd + liftIO $ System.Process.callCommand cmd + +saveLLVM :: Path -> PipelineM () +saveLLVM path = do + e <- use psExp + Just typeEnv <- use psTypeEnv + fname <- relPath path + let code = CGLLVM.codeGen typeEnv e + let llName = printf "%s.ll" fname + let sName = printf "%s.s" fname + pipelineLog "* to LLVM *" + void $ liftIO $ CGLLVM.toLLVM llName code + pipelineLog"* LLVM X64 codegen *" + callCommand $ printf "opt-7 -O3 %s | llc-7 -o %s" llName (sName :: String) + +saveExecutable :: Bool -> Path -> PipelineM () +saveExecutable debugSymbols path = do + pipelineLog "* generate llvm x64 optcode *" + let grinOptCodePath = Rel "grin-opt-code" + pipelineStep $ SaveLLVM grinOptCodePath + grinOptCodeFile <- relPath grinOptCodePath + fname <- relPath path + pipelineLog "* generate executable *" + callCommand $ printf + ("llc-7 -O3 -relocation-model=pic -filetype=obj %s.ll" ++ if debugSymbols then " -debugger-tune=gdb" else "") + grinOptCodeFile + callCommand $ printf + ("clang-7 -O3 prim_ops.c runtime.c %s.o -s -o %s" ++ if debugSymbols then " -g" else "") + grinOptCodeFile fname + +debugTransformation :: (Exp -> Exp) -> PipelineM () +debugTransformation t = do + e <- use psExp + liftIO . print $ pretty (t e) + +lintGrin :: Maybe String -> PipelineM () +lintGrin mPhaseName = do + o <- ask + when (o ^. poTypedLint) $ void $ do + pipelineStep $ HPT Compile + pipelineStep $ HPT RunPure + exp <- use psExp + mTypeEnv <- use psTypeEnv + -- By default we don't run the DDE related warnings. They should be enabled + -- when we do refactor on transformations to not to create non-DDE conforming + -- nodes, and they should be removed when we refactor the possible syntax. + let lintExp@(_, errorMap) = Lint.lint Lint.noDDEWarnings mTypeEnv exp + psErrors .= (fmap Lint.message $ concat $ Map.elems errorMap) + + -- print errors + errors <- use psErrors + unless (Prelude.null errors) $ void $ do + failOnLintError <- view poFailOnLint + when failOnLintError $ void $ do + pipelineLog $ show $ prettyLintExp lintExp + pipelineStep $ HPT PrintResult + case mPhaseName of + Just phaseName -> pipelineLog $ printf "error after %s:\n%s" phaseName (unlines errors) + Nothing -> pipelineLog $ printf "error:\n%s" (unlines errors) + saveTransformationInfo "Lint" $ prettyLintExp lintExp + mHptResult <- use psHPTResult + saveTransformationInfo "HPT-Result" mHptResult + when failOnLintError $ do + -- FIXME: reenable after: undefined support ; transformation to inject default alts for pattern match errors + -- liftIO $ die "illegal code" + pure () + +-- confluence testing + +randomPipeline :: StdGen -> PipelineOpts -> Exp -> IO Exp +randomPipeline seed opts exp + = fmap snd $ runPipeline opts emptyTypeEnv exp $ randomPipelineM seed + +-- Generate random pipeline based on the transformationWhitelist, the pipeline reaches a fixpoint +-- and returns the list of transformation that helped to reach the fixpoint. +randomPipelineM :: StdGen -> PipelineM [Transformation] +randomPipelineM seed = do + liftIO $ setStdGen seed + runBasicAnalyses + go transformationWhitelist [] + where + go :: [Transformation] -> [Transformation] -> PipelineM [Transformation] + go [] result = do + -- The final result must be normalised as, non-normalised and normalised + -- grin program is semantically the same. + pipelineStep $ T BindNormalisation + pure $ reverse result + go available res = do + exp <- use psExp + t <- fmap ((available !!) . abs . (`mod` (length available))) $ liftIO $ randomIO + eff <- if needsCByLVA t + then do + runNameIntro + runCByLVA + pipelineStep (T t) + runCleanup + exp' <- use psExp + pure $ if exp == exp' then None else ExpChanged + else pipelineStep (T t) + case eff of + None -> go (available Data.List.\\ [t]) res + ExpChanged -> do + lintGrin . Just $ show t + runBasicAnalyses + go transformationWhitelist (t:res) + + transformationWhitelist :: [Transformation] + transformationWhitelist = + -- Misc + [ UnitPropagation + -- Optimizations + , EvaluatedCaseElimination + , TrivialCaseElimination + , SparseCaseOptimisation + , UpdateElimination + , NonSharedElimination + , CopyPropagation + , ConstantPropagation + , SimpleDeadFunctionElimination + , SimpleDeadParameterElimination + , SimpleDeadVariableElimination + , DeadFunctionElimination + , DeadDataElimination + , DeadVariableElimination + , DeadParameterElimination + , CommonSubExpressionElimination + , CaseCopyPropagation + , CaseHoisting + , GeneralizedUnboxing + , ArityRaising + , LateInlining + ] + + runBasicAnalyses :: PipelineM () + runBasicAnalyses = mapM_ pipelineStep + [ Sharing Compile + , Sharing RunPure + , ET Compile + , ET RunPure + ] + + runCByLVA :: PipelineM () + runCByLVA = mapM_ pipelineStep + [ CBy Compile + , CBy RunPure + , LVA Compile + , LVA RunPure + , ET Compile + , ET RunPure + ] + + runNameIntro :: PipelineM () + runNameIntro = void . pipelineStep $ Pass + [ T ProducerNameIntroduction + , T BindNormalisation + , T BindingPatternSimplification + , T BindNormalisation + ] + + -- cleanup after producer name intro + runCleanup :: PipelineM () + runCleanup = void . pipelineStep $ Pass + [ T CopyPropagation + , T SimpleDeadVariableElimination + ] + + needsCByLVA :: Transformation -> Bool + needsCByLVA = \case + DeadFunctionElimination -> True + DeadDataElimination -> True + DeadVariableElimination -> True + DeadParameterElimination -> True + _ -> False + + needsCleanup :: Transformation -> Bool + needsCleanup = needsCByLVA + +confluenceTest :: PipelineM () +confluenceTest = do + pipelineLog "Confluence test" + pipelineLog "Random pipeline #1" + state <- MonadState.get + gen1 <- liftIO newStdGen + pipeline1 <- randomPipelineM gen1 + pipelineLog "Random pipeline #2" + exp1 <- use psExp + MonadState.put state + gen2 <- liftIO newStdGen + pipeline2 <- randomPipelineM gen2 + exp2 <- use psExp + if (mangleNames exp1 /= mangleNames exp2) + then do + let [lines1, lines2] = lines . show . plain . pretty <$> [exp1, exp2] + pipelineLog "\nDiff between transformed codes:" + pipelineLog $ ppDiff $ getGroupedDiff lines1 lines2 + else + pipelineLog "The calculated fixpoint is the same for the pipelines:" + pipelineLog "First tranformation permutation:" + pipelineLog $ show pipeline1 + pipelineLog "\nSecond transformation permutation:" + pipelineLog $ show pipeline2 + +runPipeline :: PipelineOpts -> TypeEnv -> Exp -> PipelineM a -> IO (a, Exp) +runPipeline o ta e m = do + createDirectoryIfMissing True $ _poOutputDir o + fmap (second _psExp) $ flip runStateT start $ runReaderT m o where + start = PState + { _psExp = e + , _psTransStep = 0 + , _psSaveIdx = 0 + , _psHPTProgram = Nothing + , _psHPTResult = Nothing + , _psCByProgram = Nothing + , _psCByResult = Nothing + , _psLVAProgram = Nothing + , _psLVAResult = Nothing + , _psETProgram = Nothing + , _psETResult = Nothing + , _psSharingResult = Nothing + , _psSharingProgram = Nothing + , _psTypeEnv = Nothing + , _psTypeAnnots = ta + , _psEffectMap = Nothing + , _psErrors = [] + , _psIntendation = 0 + } + +-- | Runs the pipeline and returns the last version of the given +-- expression. +pipeline :: PipelineOpts -> Maybe TypeEnv -> Exp -> [PipelineStep] -> IO Exp +pipeline o mte e ps = fmap snd $ runPipeline o (fromMaybe emptyTypeEnv mte) e $ mapM pipelineStep ps + +optimize :: PipelineOpts -> Exp -> [PipelineStep] -> [PipelineStep] -> IO Exp +optimize o e pre post = optimizeWith o e pre defaultOptimizations post + +optimizeWith :: PipelineOpts -> Exp -> [PipelineStep] -> [Transformation] -> [PipelineStep] -> IO Exp +optimizeWith o e pre ts post = + fmap snd $ runPipeline o emptyTypeEnv e $ optimizeWithM pre ts post + +-- | Run the pipeline with the given set of transformations, till +-- it reaches a fixpoint where none of the pipeline transformations +-- change the expression itself, the order of the transformations +-- are defined in the pipeline list. When the expression changes, +-- it lints the resulting code. +-- +-- phase optimisation +-- - loop over transformations while the expression changes in one phase +-- - bump to the next phase when the expression did not change +-- - phases are ordered via complexity +-- - the expression reaches a fixpoint when none of the phases did change the expression +optimizeWithM :: [PipelineStep] -> [Transformation] -> [PipelineStep] -> PipelineM () +optimizeWithM pre trans post = do + mapM_ pipelineStep pre + loop + mapM_ pipelineStep post + where + loop = do + pipelineLog "PHASE #1" + c1 <- phase1 + pipelineLog "PHASE #2" + c2 <- phase2 + pipelineLog "PHASE #3" + c3 <- phase3 + pipelineLog "PHASE #4" + c4 <- phase4 + when (or [c1, c2, c3, c4]) loop + + phaseLoop _ [] = pure False + phaseLoop isChanged ts = do + o <- ask + effs <- forM (BindNormalisation:ts) $ \t -> do + eff <- pipelineStep (T t) + when (eff == ExpChanged) $ do + let tname = (fmap (\case ' ' -> '-' ; c -> c) $ show t) + pipelineStep $ SaveGrin $ Rel $ tname <.> "grin" + when (o ^. poSaveBinary) $ void $ pipelineStep $ SaveBinary tname + when (o ^. poLintOnChange) $ lintGrin $ Just $ show t + when (o ^. poStatistics) $ void $ pipelineStep Statistics + when (o ^. poSaveTypeEnv) $ void $ pipelineStep SaveTypeEnv + pure eff + if (any (==ExpChanged) effs) + then phaseLoop True ts + else pure isChanged + + -- No analysis is required + phase1 = phaseLoop False $ trans `intersect` + [ EvaluatedCaseElimination + , TrivialCaseElimination + , UpdateElimination + , CopyPropagation + , ConstantPropagation + , SimpleDeadFunctionElimination + , SimpleDeadParameterElimination + , CaseCopyPropagation + ] + + -- HPT is required + phase2 = phaseLoop False $ trans `intersect` + [ InlineEval + , InlineApply + , InlineBuiltins + , CaseHoisting + , GeneralizedUnboxing + , ArityRaising + , LateInlining + , UnitPropagation + , SparseCaseOptimisation + ] + + -- HPT and Sharing/Eff is required + phase3 = phaseLoop False $ trans `intersect` + [ SimpleDeadVariableElimination + , CommonSubExpressionElimination + , NonSharedElimination + ] + + -- HPT LVA CBy is required + -- Only run this phase when interprocedural transformations are required. + phase4 = if (null (trans `intersect` + [ DeadDataElimination + , DeadFunctionElimination + , DeadParameterElimination + , DeadVariableElimination + ])) + then pure False + else phase4Loop False + + phase4Loop isChanged = do + o <- ask + expBefore <- use psExp + forM_ steps $ \step -> do + eff <- pipelineStep step + when (eff == ExpChanged) $ void $ do + pipelineStep $ SaveGrin $ Rel $ (fmap (\case ' ' -> '-' ; c -> c) $ show step) <.> "grin" + when (o ^. poLintOnChange) $ lintGrin $ Just $ show step + when (o ^. poStatistics) $ void $ pipelineStep Statistics + when (o ^. poSaveTypeEnv) $ void $ pipelineStep SaveTypeEnv + expAfter <- use psExp + if (mangleNames expBefore /= mangleNames expAfter) + then phase4Loop True + else pure isChanged + where + steps = concat + [ map T + [ CopyPropagation + , SimpleDeadVariableElimination + , ProducerNameIntroduction + , BindNormalisation + , BindingPatternSimplification + , BindNormalisation + , UnitPropagation + ] + , map T $ trans `intersect` + [ DeadFunctionElimination + , DeadDataElimination + , DeadVariableElimination + , DeadParameterElimination + ] + , map T + [ CopyPropagation + , SimpleDeadVariableElimination + , BindNormalisation + , UnitPropagation + ] + ] + +invalidateAnalysisResults :: PipelineM () +invalidateAnalysisResults = do + pipelineLog "Invalidating type environment" + psHPTProgram .= Nothing + psHPTResult .= Nothing + psCByProgram .= Nothing + psCByResult .= Nothing + psLVAProgram .= Nothing + psLVAResult .= Nothing + psETProgram .= Nothing + psETResult .= Nothing + psSharingProgram .= Nothing + psSharingResult .= Nothing + psTypeEnv .= Nothing + psEffectMap .= Nothing + +runAnalysisFor :: Transformation -> PipelineM () +runAnalysisFor t = do + n <- use psTransStep + sequence_ $ case transformationFunc n t of + Plain _ -> [] + WithTypeEnv _ -> [hpt] + WithTypeEnvEff _ -> [hpt, eff] + WithLVA _ -> [hpt, lva] + WithLVACBy _ -> [hpt, cby, lva, sharing] + WithTypeEnvShr _ -> [hpt, sharing] + where + analysis getter ann = do + r <- use getter + when (isNothing r) $ do + pipelineLog "" + pipelineLog $ "Analysis" + mapM_ pipelineStep $ (ann <$> [Compile, RunPure]) + + hpt = analysis psHPTResult HPT + lva = analysis psLVAResult LVA + cby = analysis psCByResult CBy + et = analysis psETResult ET + sharing = analysis psSharingResult Sharing + + eff :: PipelineM () + eff = do + r <- use psEffectMap + when (isNothing r) $ do + pipelineLog "" + pipelineLog $ "Analysis" + void $ pipelineStep $ Eff CalcEffectMap + +inceaseIntendation :: PipelineM () +inceaseIntendation = psIntendation %= succ + +decreateIntendation :: PipelineM () +decreateIntendation = psIntendation %= pred + +pipelineLog :: String -> PipelineM () +pipelineLog str = do + shouldLog <- view poLogging + ident <- use psIntendation + when shouldLog $ liftIO $ putStrLn $ replicate ident ' ' ++ str + +pipelineLogNoLn :: String -> PipelineM () +pipelineLogNoLn str = do + shouldLog <- view poLogging + ident <- use psIntendation + when shouldLog $ liftIO $ putStr $ replicate ident ' ' ++ str + +pipelineLogIterations :: Int -> PipelineM () +pipelineLogIterations n = pipelineLogNoLn $ "iterations: " ++ show n ++ " " + +defaultOptimizations :: [Transformation] +defaultOptimizations = + [ InlineEval + , SparseCaseOptimisation + , SimpleDeadFunctionElimination + , SimpleDeadParameterElimination + , SimpleDeadVariableElimination + , EvaluatedCaseElimination + , TrivialCaseElimination + , UpdateElimination + , NonSharedElimination + , CopyPropagation + , ConstantPropagation + , CommonSubExpressionElimination + , CaseCopyPropagation + , CaseHoisting + , GeneralizedUnboxing + , ArityRaising + , InlineApply + , LateInlining + ] + +debugPipeline :: [PipelineStep] -> [PipelineStep] +debugPipeline ps = [SimplePrintGrin id] ++ ps ++ [SimplePrintGrin id] + +debugPipelineState :: PipelineM () +debugPipelineState = do + ps <- MonadState.get + liftIO $ print ps + +printingSteps :: [PipelineStep] +printingSteps = + [ HPT PrintProgram + , HPT PrintResult + , CBy PrintProgram + , CBy PrintResult + , LVA PrintProgram + , LVA PrintResult + , ET PrintProgram + , ET PrintResult + , Sharing PrintProgram + , Sharing PrintResult + , PrintTypeEnv + , Eff PrintEffectMap + , PrintAST + , PrintErrors + , PrintTypeAnnots + , DebugPipelineState + , SimplePrintGrin id + ] + +isPrintingStep :: PipelineStep -> Bool +isPrintingStep = flip elem printingSteps From 886d6c172e702763f1ec2cd58af206dbbc821c6a Mon Sep 17 00:00:00 2001 From: anabra Date: Mon, 17 Feb 2020 01:08:23 +0100 Subject: [PATCH 04/11] ES: renamed transformations in Pipeline --- grin/src/Pipeline/ExtendedSyntax/Pipeline.hs | 218 ++++++++----------- 1 file changed, 87 insertions(+), 131 deletions(-) diff --git a/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs b/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs index 3dbcd190..86d206c6 100644 --- a/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs +++ b/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs @@ -28,60 +28,51 @@ import Text.Pretty.Simple (pPrint) import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (), (<$$>)) import qualified Text.Show.Pretty as PP -import Pipeline.Eval -import Grin.Grin -import Grin.TypeEnv -import Grin.TypeCheck -import Grin.EffectMap hiding (Eff) -import Pipeline.Optimizations -import qualified Grin.Statistics as Statistics -import Grin.Parse -import Grin.Pretty(showWide, prettyProgram, RenderingOption(..)) -import Transformations.CountVariableUse -import Transformations.GenerateEval -import qualified Transformations.Simplifying.Vectorisation2 as Vectorisation2 -import Transformations.Simplifying.Vectorisation -import Transformations.BindNormalisation -import qualified Grin.Lint as Lint -import Grin.PrettyLint -import Transformations.Simplifying.SplitFetch -import Transformations.Simplifying.BindingPatternSimplification -import Transformations.Simplifying.CaseSimplification -import Transformations.Optimising.Inlining (inlineEval, inlineApply, inlineBuiltins) -import Transformations.UnitPropagation -import Transformations.MangleNames -import Transformations.EffectMap -import Transformations.StaticSingleAssignment -import Transformations.Names (ExpChanges(..)) -import qualified Transformations.Simplifying.RightHoistFetch2 as RHF -import Transformations.Simplifying.RegisterIntroduction -import Transformations.Simplifying.ProducerNameIntroduction -import qualified AbstractInterpretation.HeapPointsTo.Result as HPT -import qualified AbstractInterpretation.CreatedBy.Readback as CBy -import qualified AbstractInterpretation.CreatedBy.Result as CBy -import qualified AbstractInterpretation.LiveVariable.Result as LVA -import qualified AbstractInterpretation.EffectTracking.Result as ET -import qualified AbstractInterpretation.Sharing.Result as Sharing -import AbstractInterpretation.BinaryIR -import AbstractInterpretation.OptimiseAbstractProgram -import AbstractInterpretation.CreatedBy.Pretty -import AbstractInterpretation.HeapPointsTo.Pretty -import AbstractInterpretation.LiveVariable.Pretty -import AbstractInterpretation.EffectTracking.Pretty -import AbstractInterpretation.Sharing.Pretty -import AbstractInterpretation.Sharing.CodeGen -import AbstractInterpretation.Reduce (ComputerState, AbstractInterpretationResult(..), evalAbstractProgram) -import qualified AbstractInterpretation.PrettyIR as IR -import qualified AbstractInterpretation.IR as IR -import qualified AbstractInterpretation.HeapPointsTo.CodeGen as HPT -import qualified AbstractInterpretation.HeapPointsTo.CodeGenBase as HPT -import qualified AbstractInterpretation.CreatedBy.CodeGen as CBy -import qualified AbstractInterpretation.LiveVariable.CodeGen as LVA -import qualified AbstractInterpretation.EffectTracking.CodeGen as ET -import qualified AbstractInterpretation.EffectTracking.CodeGenBase as ET -import qualified AbstractInterpretation.Sharing.CodeGen as Sharing -import qualified Reducer.LLVM.CodeGen as CGLLVM -import qualified Reducer.LLVM.JIT as JITLLVM +import Pipeline.ExtendedSyntax.Eval +import Grin.ExtendedSyntax.Grin +import Grin.ExtendedSyntax.TypeEnv +import Grin.ExtendedSyntax.TypeCheck +import Grin.ExtendedSyntax.EffectMap hiding (Eff) +import Pipeline.ExtendedSyntax.Optimizations +import qualified Grin.ExtendedSyntax.Statistics as Statistics +import Grin.ExtendedSyntax.Parse +import Grin.ExtendedSyntax.Pretty(showWide, prettyProgram, RenderingOption(..)) +import Transformations.ExtendedSyntax.CountVariableUse +import Transformations.ExtendedSyntax.GenerateEval +import Transformations.ExtendedSyntax.BindNormalisation +import qualified Grin.ExtendedSyntax.Lint as Lint +import Grin.ExtendedSyntax.PrettyLint +import Transformations.ExtendedSyntax.Optimising.Inlining (inlineEval, inlineApply, inlineBuiltins) +import Transformations.ExtendedSyntax.MangleNames +import Transformations.ExtendedSyntax.EffectMap +import Transformations.ExtendedSyntax.StaticSingleAssignment +import Transformations.ExtendedSyntax.Names (ExpChanges(..)) +import qualified AbstractInterpretation.ExtendedSyntax.HeapPointsTo.Result as HPT +import qualified AbstractInterpretation.ExtendedSyntax.CreatedBy.Readback as CBy +import qualified AbstractInterpretation.ExtendedSyntax.CreatedBy.Result as CBy +import qualified AbstractInterpretation.ExtendedSyntax.LiveVariable.Result as LVA +import qualified AbstractInterpretation.ExtendedSyntax.EffectTracking.Result as ET +import qualified AbstractInterpretation.ExtendedSyntax.Sharing.Result as Sharing +import AbstractInterpretation.ExtendedSyntax.BinaryIR +import AbstractInterpretation.ExtendedSyntax.OptimiseAbstractProgram +import AbstractInterpretation.ExtendedSyntax.CreatedBy.Pretty +import AbstractInterpretation.ExtendedSyntax.HeapPointsTo.Pretty +import AbstractInterpretation.ExtendedSyntax.LiveVariable.Pretty +import AbstractInterpretation.ExtendedSyntax.EffectTracking.Pretty +import AbstractInterpretation.ExtendedSyntax.Sharing.Pretty +import AbstractInterpretation.ExtendedSyntax.Sharing.CodeGen +import AbstractInterpretation.ExtendedSyntax.Reduce (ComputerState, AbstractInterpretationResult(..), evalAbstractProgram) +import qualified AbstractInterpretation.ExtendedSyntax.PrettyIR as IR +import qualified AbstractInterpretation.ExtendedSyntax.IR as IR +import qualified AbstractInterpretation.ExtendedSyntax.HeapPointsTo.CodeGen as HPT +import qualified AbstractInterpretation.ExtendedSyntax.HeapPointsTo.CodeGenBase as HPT +import qualified AbstractInterpretation.ExtendedSyntax.CreatedBy.CodeGen as CBy +import qualified AbstractInterpretation.ExtendedSyntax.LiveVariable.CodeGen as LVA +import qualified AbstractInterpretation.ExtendedSyntax.EffectTracking.CodeGen as ET +import qualified AbstractInterpretation.ExtendedSyntax.EffectTracking.CodeGenBase as ET +import qualified AbstractInterpretation.ExtendedSyntax.Sharing.CodeGen as Sharing +import qualified Reducer.ExtendedSyntax.LLVM.CodeGen as CGLLVM +import qualified Reducer.ExtendedSyntax.LLVM.JIT as JITLLVM import System.Directory import qualified System.Process import Data.Bifunctor @@ -121,38 +112,27 @@ import qualified Data.ByteString.Lazy as LBS data Transformation -- Simplifying - = RegisterIntroduction - | ProducerNameIntroduction - | BindingPatternSimplification - | Vectorisation - | SplitFetch - | CaseSimplification - | RightHoistFetch - | InlineEval + = InlineEval | InlineApply | InlineBuiltins -- Misc | GenerateEval | BindNormalisation - | ConstantFolding - | UnitPropagation | MangleNames | StaticSingleAssignment -- Optimizations | EvaluatedCaseElimination | TrivialCaseElimination | SparseCaseOptimisation - | UpdateElimination | NonSharedElimination | CopyPropagation | ConstantPropagation - | DeadDataElimination + | InterproceduralDeadDataElimination + | InterproceduralDeadFunctionElimination + | InterproceduralDeadParameterElimination | DeadFunctionElimination - | DeadParameterElimination | DeadVariableElimination - | SimpleDeadFunctionElimination - | SimpleDeadVariableElimination - | SimpleDeadParameterElimination + | DeadParameterElimination | CommonSubExpressionElimination | CaseCopyPropagation | CaseHoisting @@ -213,12 +193,12 @@ data PipelineStep | DebugPipelineState deriving (Eq, Show) -pattern DeadCodeElimination :: PipelineStep -pattern DeadCodeElimination = Pass - [ T DeadFunctionElimination - , T DeadDataElimination - , T DeadVariableElimination - , T DeadParameterElimination +-- TODO: maybe we will need DVE & CopyPropgation here as well +pattern InterproceduralDeadCodeElimination :: PipelineStep +pattern InterproceduralDeadCodeElimination = Pass + [ T InterproceduralDeadFunctionElimination + , T InterproceduralDeadDataElimination + , T InterproceduralDeadParameterElimination ] pattern HPTPass :: PipelineStep @@ -324,28 +304,19 @@ data TransformationFunc -- TODO: Add n paramter for the transformations that use NameM transformationFunc :: Int -> Transformation -> TransformationFunc transformationFunc n = \case - Vectorisation -> WithTypeEnv (newNames <$$> Right <$$> Vectorisation2.vectorisation) GenerateEval -> Plain generateEval - CaseSimplification -> Plain (noNewNames . caseSimplification) - SplitFetch -> Plain (noNewNames . splitFetch) - RegisterIntroduction -> Plain (newNames . registerIntroductionI n) -- TODO - ProducerNameIntroduction -> Plain producerNameIntroduction - BindingPatternSimplification -> Plain bindingPatternSimplification - RightHoistFetch -> Plain (noNewNames . RHF.rightHoistFetch) -- misc MangleNames -> Plain (newNames . mangleNames) -- TODO StaticSingleAssignment -> Plain (newNames . staticSingleAssignment) -- TODO BindNormalisation -> Plain (noNewNames . bindNormalisation) - ConstantFolding -> Plain (newNames . constantFolding) -- optimising EvaluatedCaseElimination -> Plain (noNewNames . evaluatedCaseElimination) TrivialCaseElimination -> Plain (noNewNames . trivialCaseElimination) - UpdateElimination -> Plain (noNewNames . updateElimination) CopyPropagation -> Plain (noNewNames . copyPropagation) -- TODO ConstantPropagation -> Plain (noNewNames . constantPropagation) -- TODO - SimpleDeadFunctionElimination -> Plain (noNewNames . simpleDeadFunctionElimination) - SimpleDeadParameterElimination -> Plain (noNewNames . simpleDeadParameterElimination) - SimpleDeadVariableElimination -> WithTypeEnvEff (noNewNames <$$$> simpleDeadVariableElimination) + DeadFunctionElimination -> Plain (noNewNames . deadFunctionElimination) + DeadParameterElimination -> Plain (noNewNames . deadParameterElimination) + DeadVariableElimination -> WithTypeEnvEff (noNewNames <$$$> deadVariableElimination) InlineEval -> WithTypeEnv (Right <$$> inlineEval) InlineApply -> WithTypeEnv (Right <$$> inlineApply) InlineBuiltins -> WithTypeEnv (Right <$$> inlineBuiltins) @@ -355,12 +326,10 @@ transformationFunc n = \case GeneralizedUnboxing -> WithTypeEnv (Right <$$> generalizedUnboxing) ArityRaising -> WithTypeEnv (Right <$$> (arityRaising n)) LateInlining -> WithTypeEnv (Right <$$> lateInlining) - UnitPropagation -> WithTypeEnv (noNewNames <$$> Right <$$> unitPropagation) NonSharedElimination -> WithTypeEnvShr nonSharedElimination - DeadFunctionElimination -> WithLVA (noNewNames <$$$$> deadFunctionElimination) - DeadVariableElimination -> WithLVA (noNewNames <$$$$> deadVariableElimination) - DeadParameterElimination -> WithLVA (noNewNames <$$$$> deadParameterElimination) - DeadDataElimination -> WithLVACBy deadDataElimination + InterproceduralDeadFunctionElimination -> WithLVA (noNewNames <$$$$> interproceduralDeadFunctionElimination) + InterproceduralDeadParameterElimination -> WithLVA (noNewNames <$$$$> interproceduralDeadParameterElimination) + InterproceduralDeadDataElimination -> WithLVACBy interproceduralDeadDataElimination SparseCaseOptimisation -> WithTypeEnv (noNewNames <$$$> sparseCaseOptimisation) where noNewNames = flip (,) NoChange @@ -811,22 +780,18 @@ randomPipelineM seed = do transformationWhitelist :: [Transformation] transformationWhitelist = -- Misc - [ UnitPropagation - -- Optimizations - , EvaluatedCaseElimination + [ EvaluatedCaseElimination , TrivialCaseElimination , SparseCaseOptimisation - , UpdateElimination , NonSharedElimination , CopyPropagation , ConstantPropagation - , SimpleDeadFunctionElimination - , SimpleDeadParameterElimination - , SimpleDeadVariableElimination , DeadFunctionElimination - , DeadDataElimination - , DeadVariableElimination , DeadParameterElimination + , DeadVariableElimination + , InterproceduralDeadFunctionElimination + , InterproceduralDeadDataElimination + , InterproceduralDeadParameterElimination , CommonSubExpressionElimination , CaseCopyPropagation , CaseHoisting @@ -853,11 +818,10 @@ randomPipelineM seed = do , ET RunPure ] + -- TODO: no longer needed runNameIntro :: PipelineM () runNameIntro = void . pipelineStep $ Pass - [ T ProducerNameIntroduction - , T BindNormalisation - , T BindingPatternSimplification + [ T BindNormalisation , T BindNormalisation ] @@ -865,15 +829,15 @@ randomPipelineM seed = do runCleanup :: PipelineM () runCleanup = void . pipelineStep $ Pass [ T CopyPropagation - , T SimpleDeadVariableElimination + , T DeadVariableElimination ] needsCByLVA :: Transformation -> Bool needsCByLVA = \case - DeadFunctionElimination -> True - DeadDataElimination -> True + InterproceduralDeadFunctionElimination -> True + InterproceduralDeadDataElimination -> True DeadVariableElimination -> True - DeadParameterElimination -> True + InterproceduralDeadParameterElimination -> True _ -> False needsCleanup :: Transformation -> Bool @@ -990,11 +954,10 @@ optimizeWithM pre trans post = do phase1 = phaseLoop False $ trans `intersect` [ EvaluatedCaseElimination , TrivialCaseElimination - , UpdateElimination , CopyPropagation , ConstantPropagation - , SimpleDeadFunctionElimination - , SimpleDeadParameterElimination + , DeadFunctionElimination + , DeadParameterElimination , CaseCopyPropagation ] @@ -1007,13 +970,12 @@ optimizeWithM pre trans post = do , GeneralizedUnboxing , ArityRaising , LateInlining - , UnitPropagation , SparseCaseOptimisation ] -- HPT and Sharing/Eff is required phase3 = phaseLoop False $ trans `intersect` - [ SimpleDeadVariableElimination + [ DeadVariableElimination , CommonSubExpressionElimination , NonSharedElimination ] @@ -1021,9 +983,9 @@ optimizeWithM pre trans post = do -- HPT LVA CBy is required -- Only run this phase when interprocedural transformations are required. phase4 = if (null (trans `intersect` - [ DeadDataElimination - , DeadFunctionElimination - , DeadParameterElimination + [ InterproceduralDeadDataElimination + , InterproceduralDeadFunctionElimination + , InterproceduralDeadParameterElimination , DeadVariableElimination ])) then pure False @@ -1047,24 +1009,19 @@ optimizeWithM pre trans post = do steps = concat [ map T [ CopyPropagation - , SimpleDeadVariableElimination - , ProducerNameIntroduction + , DeadVariableElimination , BindNormalisation - , BindingPatternSimplification , BindNormalisation - , UnitPropagation ] , map T $ trans `intersect` - [ DeadFunctionElimination - , DeadDataElimination - , DeadVariableElimination - , DeadParameterElimination + [ InterproceduralDeadFunctionElimination + , InterproceduralDeadDataElimination + , InterproceduralDeadParameterElimination ] , map T [ CopyPropagation - , SimpleDeadVariableElimination + , DeadVariableElimination , BindNormalisation - , UnitPropagation ] ] @@ -1141,12 +1098,11 @@ defaultOptimizations :: [Transformation] defaultOptimizations = [ InlineEval , SparseCaseOptimisation - , SimpleDeadFunctionElimination - , SimpleDeadParameterElimination - , SimpleDeadVariableElimination + , DeadFunctionElimination + , DeadParameterElimination + , DeadVariableElimination , EvaluatedCaseElimination , TrivialCaseElimination - , UpdateElimination , NonSharedElimination , CopyPropagation , ConstantPropagation From 2146e6d447752b71cd06cbfe933ab449fe79316a Mon Sep 17 00:00:00 2001 From: anabra Date: Mon, 17 Feb 2020 01:21:20 +0100 Subject: [PATCH 05/11] ES: fixed Pipepile transformation machinery --- grin/src/Pipeline/ExtendedSyntax/Pipeline.hs | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs b/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs index 86d206c6..acb7f098 100644 --- a/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs +++ b/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs @@ -12,7 +12,7 @@ module Pipeline.ExtendedSyntax.Pipeline , pattern PrintGrin , pattern SimplePrintGrin , pattern FullPrintGrin - , pattern DeadCodeElimination + , pattern InterproceduralDeadCodeElimination , pipeline , optimize , optimizeWith @@ -73,6 +73,8 @@ import qualified AbstractInterpretation.ExtendedSyntax.EffectTracking.CodeGenBas import qualified AbstractInterpretation.ExtendedSyntax.Sharing.CodeGen as Sharing import qualified Reducer.ExtendedSyntax.LLVM.CodeGen as CGLLVM import qualified Reducer.ExtendedSyntax.LLVM.JIT as JITLLVM +import Grin.ExtendedSyntax.Nametable as Nametable + import System.Directory import qualified System.Process import Data.Bifunctor @@ -106,7 +108,6 @@ import Data.Functor.Infix import Data.Maybe (isNothing) import System.IO (BufferMode(..), hSetBuffering, stdout) import Data.Binary as Binary -import Grin.Nametable as Nametable import qualified Data.ByteString.Lazy as LBS @@ -296,8 +297,9 @@ _ExpChanged _ rest = pure rest data TransformationFunc = Plain (Exp -> (Exp, ExpChanges)) | WithTypeEnv (TypeEnv -> Exp -> Either String (Exp, ExpChanges)) + | WithEff (EffectMap -> Exp -> (Exp, ExpChanges)) + | WithShr (Sharing.SharingResult -> Exp -> (Exp, ExpChanges)) | WithTypeEnvEff (TypeEnv -> EffectMap -> Exp -> (Exp, ExpChanges)) - | WithTypeEnvShr (Sharing.SharingResult -> TypeEnv -> Exp -> (Exp, ExpChanges)) | WithLVA (LVA.LVAResult -> TypeEnv -> Exp -> Either String (Exp, ExpChanges)) | WithLVACBy (LVA.LVAResult -> CBy.CByResult -> TypeEnv -> Exp -> Either String (Exp, ExpChanges)) @@ -316,7 +318,7 @@ transformationFunc n = \case ConstantPropagation -> Plain (noNewNames . constantPropagation) -- TODO DeadFunctionElimination -> Plain (noNewNames . deadFunctionElimination) DeadParameterElimination -> Plain (noNewNames . deadParameterElimination) - DeadVariableElimination -> WithTypeEnvEff (noNewNames <$$$> deadVariableElimination) + DeadVariableElimination -> WithEff (noNewNames <$$> deadVariableElimination) InlineEval -> WithTypeEnv (Right <$$> inlineEval) InlineApply -> WithTypeEnv (Right <$$> inlineApply) InlineBuiltins -> WithTypeEnv (Right <$$> inlineBuiltins) @@ -326,7 +328,7 @@ transformationFunc n = \case GeneralizedUnboxing -> WithTypeEnv (Right <$$> generalizedUnboxing) ArityRaising -> WithTypeEnv (Right <$$> (arityRaising n)) LateInlining -> WithTypeEnv (Right <$$> lateInlining) - NonSharedElimination -> WithTypeEnvShr nonSharedElimination + NonSharedElimination -> WithShr nonSharedElimination InterproceduralDeadFunctionElimination -> WithLVA (noNewNames <$$$$> interproceduralDeadFunctionElimination) InterproceduralDeadParameterElimination -> WithLVA (noNewNames <$$$$> interproceduralDeadParameterElimination) InterproceduralDeadDataElimination -> WithLVACBy interproceduralDeadDataElimination @@ -350,10 +352,11 @@ transformation t = do case transformationFunc n t of Plain f -> Right $ f e WithTypeEnv f -> f te e + WithEff f -> Right $ f em e + WithShr f -> Right $ f shr e WithTypeEnvEff f -> Right $ f te em e WithLVA f -> f lva te e WithLVACBy f -> f lva cby te e - WithTypeEnvShr f -> Right $ f shr te e psTransStep %= (+1) where onExp (e, changes) = do @@ -1047,10 +1050,10 @@ runAnalysisFor t = do sequence_ $ case transformationFunc n t of Plain _ -> [] WithTypeEnv _ -> [hpt] + WithEff _ -> [eff] WithTypeEnvEff _ -> [hpt, eff] WithLVA _ -> [hpt, lva] WithLVACBy _ -> [hpt, cby, lva, sharing] - WithTypeEnvShr _ -> [hpt, sharing] where analysis getter ann = do r <- use getter From 76628112c5943c4f740283c1fd38cacbd3209659 Mon Sep 17 00:00:00 2001 From: anabra Date: Mon, 17 Feb 2020 01:27:01 +0100 Subject: [PATCH 06/11] ES: added PipelineSpec --- grin/grin.cabal | 1 + grin/test/ExtendedSyntax/PipelineSpec.hs | 54 ++++++++++++++++++++++++ 2 files changed, 55 insertions(+) create mode 100644 grin/test/ExtendedSyntax/PipelineSpec.hs diff --git a/grin/grin.cabal b/grin/grin.cabal index 88b661c0..1071f401 100644 --- a/grin/grin.cabal +++ b/grin/grin.cabal @@ -324,6 +324,7 @@ test-suite grin-test ExtendedSyntax.LintSpec ExtendedSyntax.NametableSpec ExtendedSyntax.ParserSpec + ExtendedSyntax.PipelineSpec ExtendedSyntax.PrimOpsSpec ExtendedSyntax.TestSpec Transformations.ExtendedSyntax.BindNormalisationSpec diff --git a/grin/test/ExtendedSyntax/PipelineSpec.hs b/grin/test/ExtendedSyntax/PipelineSpec.hs new file mode 100644 index 00000000..97a774a8 --- /dev/null +++ b/grin/test/ExtendedSyntax/PipelineSpec.hs @@ -0,0 +1,54 @@ +module ExtendedSyntax.PipelineSpec where + +import Data.Functor.Infix ((<$$>)) +import Data.List ((\\), nub) +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Monadic +import Pipeline.Pipeline +import Test.Test +import Pipeline.Eval +import Grin.Pretty +import Debug.Trace + + +runTests :: IO () +runTests = hspec spec + +spec :: Spec +spec = do + it "Exploratory testing on random program and random pipeline" $ do + pending + -- NOTE: commented out due type error + {- + property $ + forAll (PP <$> genProg) $ \(PP original) -> + -- forAllShrink genPipeline shrinkPipeline $ \ppln -> + forAll genPipeline $ \ppln -> + monadicIO $ do + (pipelineInfo, transformed) <- run $ pipeline defaultOpts original ppln + pre $ any ((==ExpChanged) . snd) pipelineInfo + traceShowM pipelineInfo + pre $ transformed /= original + originalValue <- run $ pure $ evalProgram PureReducer original + transformedValue <- run $ pure $ evalProgram PureReducer transformed + run (transformedValue `shouldBe` originalValue) + -} +genPipeline :: Gen [PipelineStep] +genPipeline = do + ([SimplePrintGrin id, HPT Compile, HPT RunPure]++) <$> (T <$$> transformations) +-- ([HPT CompileHPT, HPT RunHPTPure]++) <$> (T <$$> transformations) + +shrinkPipeline :: [PipelineStep] -> [[PipelineStep]] +shrinkPipeline (printast:chpt:hpt:rest) = ([printast, chpt, hpt]++) <$> shrinkList (const []) rest + +transformations :: Gen [Transformation] +transformations = do + ts <- shuffle [toEnum 0 .. ] + fmap nub $ listOf1 $ elements (ts \\ knownIssues) + +knownIssues :: [Transformation] +knownIssues = + [ Vectorisation -- Needs maintained HTP results + , RegisterIntroduction -- Memory leak + ] From f59283d5af33678da9f3f1ee8f31f7998e4b5192 Mon Sep 17 00:00:00 2001 From: anabra Date: Mon, 17 Feb 2020 01:42:34 +0100 Subject: [PATCH 07/11] ES: small fixes in PipelineSpec --- grin/test/ExtendedSyntax/PipelineSpec.hs | 20 ++++++-------------- 1 file changed, 6 insertions(+), 14 deletions(-) diff --git a/grin/test/ExtendedSyntax/PipelineSpec.hs b/grin/test/ExtendedSyntax/PipelineSpec.hs index 97a774a8..b0851b57 100644 --- a/grin/test/ExtendedSyntax/PipelineSpec.hs +++ b/grin/test/ExtendedSyntax/PipelineSpec.hs @@ -1,15 +1,12 @@ module ExtendedSyntax.PipelineSpec where import Data.Functor.Infix ((<$$>)) -import Data.List ((\\), nub) +import Data.List (nub) + import Test.Hspec import Test.QuickCheck -import Test.QuickCheck.Monadic -import Pipeline.Pipeline -import Test.Test -import Pipeline.Eval -import Grin.Pretty -import Debug.Trace + +import Pipeline.ExtendedSyntax.Pipeline runTests :: IO () @@ -18,7 +15,7 @@ runTests = hspec spec spec :: Spec spec = do it "Exploratory testing on random program and random pipeline" $ do - pending + pendingWith "commented out due type error" -- NOTE: commented out due type error {- property $ @@ -45,10 +42,5 @@ shrinkPipeline (printast:chpt:hpt:rest) = ([printast, chpt, hpt]++) <$> shrinkLi transformations :: Gen [Transformation] transformations = do ts <- shuffle [toEnum 0 .. ] - fmap nub $ listOf1 $ elements (ts \\ knownIssues) + fmap nub $ listOf1 $ elements ts -knownIssues :: [Transformation] -knownIssues = - [ Vectorisation -- Needs maintained HTP results - , RegisterIntroduction -- Memory leak - ] From b44720d757cfff87905bde3fcef0356c2f6cd939 Mon Sep 17 00:00:00 2001 From: anabra Date: Mon, 17 Feb 2020 15:08:11 +0100 Subject: [PATCH 08/11] ES: added ConflenceSpec --- grin/grin.cabal | 1 + .../ExtendedSyntax/ConfluenceSpec.hs | 88 +++++++++++++++++++ 2 files changed, 89 insertions(+) create mode 100644 grin/test/Transformations/ExtendedSyntax/ConfluenceSpec.hs diff --git a/grin/grin.cabal b/grin/grin.cabal index 1071f401..d98330e1 100644 --- a/grin/grin.cabal +++ b/grin/grin.cabal @@ -328,6 +328,7 @@ test-suite grin-test ExtendedSyntax.PrimOpsSpec ExtendedSyntax.TestSpec Transformations.ExtendedSyntax.BindNormalisationSpec + Transformations.ExtendedSyntax.ConfluenceSpec Transformations.ExtendedSyntax.ConversionSpec Transformations.ExtendedSyntax.MangleNamesSpec Transformations.ExtendedSyntax.StaticSingleAssignmentSpec diff --git a/grin/test/Transformations/ExtendedSyntax/ConfluenceSpec.hs b/grin/test/Transformations/ExtendedSyntax/ConfluenceSpec.hs new file mode 100644 index 00000000..1dba8b3b --- /dev/null +++ b/grin/test/Transformations/ExtendedSyntax/ConfluenceSpec.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE QuasiQuotes #-} +module Transformations.ExtendedSyntax.ConfluenceSpec where + +import Pipeline.Pipeline + +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Monadic +import Grin.TH +import Grin.PrimOpsPrelude +import Test.Assertions +import Data.List ( (\\) ) + +import Grin.Pretty (PP(..)) +import Test.Test (genProg) +import Transformations.MangleNames +import Control.Monad +import System.Random + +runTests :: IO () +runTests = hspec spec + +spec :: Spec +spec = do + let exp = withPrimPrelude [prog| + grinMain = + p1 <- store (CInt 0) + p2 <- store (CInt 1) + p3 <- store (CInt 1000) + p4 <- store (Fupto p2 p3) + p5 <- store (Fsum p1 p4) + (Fsum p15 p16) <- fetch p5 + n13' <- sum p15 p16 + _prim_int_print n13' + + sum p10 p11 = + (Fupto p17 p18) <- fetch p11 + p6 <- pure p17 + p7 <- pure p18 + (CInt n2') <- fetch p6 + (CInt n3') <- fetch p7 + b1' <- _prim_int_gt n2' n3' + do + case b1' of + #True -> + v10_1 <- pure (CNil) + case v10_1 of + (CNil) -> + (CInt n14') <- fetch p10 + pure n14' + (CCons p12 p13) -> + (CInt n5') <- fetch p10 + (CInt n6') <- fetch p12 + n7' <- _prim_int_add n5' n6' + p14 <- store (CInt n7') + sum p14 p13 + #False -> + n4' <- _prim_int_add n2' 1 + p8 <- store (CInt n4') + p9 <- store (Fupto p8 p7) + v10_2 <- pure (CCons p6 p9) + case v10_2 of + (CNil) -> + (CInt n14'_2) <- fetch p10 + pure n14'_2 + (CCons p12_2 p13_2) -> + (CInt n5'_2) <- fetch p10 + (CInt n6'_2) <- fetch p12_2 + n7'_2 <- _prim_int_add n5'_2 n6'_2 + p14_2 <- store (CInt n7'_2) + sum p14_2 p13_2 + |] + + it "Random pipeline" $ do + -- NOTE: This is a random test. This could make fail the build non-related to code changes. + let opts = defaultOpts { _poLogging = False, _poOutputDir = "/tmp" } + forAll arbitrary $ \(seed1, seed2) -> monadicIO $ run $ do + transformed1 <- randomPipeline (mkStdGen seed1) opts exp + transformed2 <- randomPipeline (mkStdGen seed2) opts exp + mangleNames transformed1 `sameAs` mangleNames transformed2 + + -- Needs better code generation. + xit "Random pipeline, random expression" $ property $ + forAll (PP <$> genProg) $ \(PP prog) -> monadicIO $ run $ do + let opts = defaultOpts { _poLogging = False, _poOutputDir = "/tmp" } + transformed1 <- randomPipeline (mkStdGen 0xffaa419371) opts exp + transformed2 <- randomPipeline (mkStdGen 0x51437291fb) opts exp + mangleNames transformed1 `sameAs` mangleNames transformed2 From e40b91fbf3e057f6efa3e95cec8a2be64fe90530 Mon Sep 17 00:00:00 2001 From: anabra Date: Mon, 17 Feb 2020 15:52:48 +0100 Subject: [PATCH 09/11] ES: some fixes in Pipeline --- grin/src/Pipeline/ExtendedSyntax/Pipeline.hs | 6 +- .../ExtendedSyntax/ConfluenceSpec.hs | 129 ++++++++++-------- 2 files changed, 79 insertions(+), 56 deletions(-) diff --git a/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs b/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs index acb7f098..d415e706 100644 --- a/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs +++ b/grin/src/Pipeline/ExtendedSyntax/Pipeline.hs @@ -1050,10 +1050,12 @@ runAnalysisFor t = do sequence_ $ case transformationFunc n t of Plain _ -> [] WithTypeEnv _ -> [hpt] - WithEff _ -> [eff] + -- TODO: EffectMap is deprecated, use EffectTracking, it does not need a type environment + WithEff _ -> [hpt, eff] + WithShr _ -> [sharing] WithTypeEnvEff _ -> [hpt, eff] WithLVA _ -> [hpt, lva] - WithLVACBy _ -> [hpt, cby, lva, sharing] + WithLVACBy _ -> [hpt, cby, lva, sharing] where analysis getter ann = do r <- use getter diff --git a/grin/test/Transformations/ExtendedSyntax/ConfluenceSpec.hs b/grin/test/Transformations/ExtendedSyntax/ConfluenceSpec.hs index 1dba8b3b..6d66edac 100644 --- a/grin/test/Transformations/ExtendedSyntax/ConfluenceSpec.hs +++ b/grin/test/Transformations/ExtendedSyntax/ConfluenceSpec.hs @@ -1,21 +1,24 @@ {-# LANGUAGE QuasiQuotes #-} module Transformations.ExtendedSyntax.ConfluenceSpec where -import Pipeline.Pipeline +import Pipeline.ExtendedSyntax.Pipeline + +import Control.Monad +import Data.List ( (\\) ) +import System.Random import Test.Hspec import Test.QuickCheck import Test.QuickCheck.Monadic -import Grin.TH -import Grin.PrimOpsPrelude -import Test.Assertions -import Data.List ( (\\) ) -import Grin.Pretty (PP(..)) -import Test.Test (genProg) -import Transformations.MangleNames -import Control.Monad -import System.Random +import Grin.ExtendedSyntax.TH +import Grin.ExtendedSyntax.PrimOpsPrelude +import Test.ExtendedSyntax.Assertions + +import Grin.ExtendedSyntax.Pretty (PP(..)) +-- TODO: replace with Test.ExtendedSyntax.New.Test +import Test.ExtendedSyntax.Old.Test (genProg) +import Transformations.ExtendedSyntax.MangleNames runTests :: IO () runTests = hspec spec @@ -24,51 +27,68 @@ spec :: Spec spec = do let exp = withPrimPrelude [prog| grinMain = - p1 <- store (CInt 0) - p2 <- store (CInt 1) - p3 <- store (CInt 1000) - p4 <- store (Fupto p2 p3) - p5 <- store (Fsum p1 p4) - (Fsum p15 p16) <- fetch p5 - n13' <- sum p15 p16 - _prim_int_print n13' + y.0 <- pure 1 + v.0 <- pure (CInt y.0) + t1 <- store v.0 + y.1 <- pure 10000 + v.1 <- pure (CInt y.1) + t2 <- store v.1 + v.2 <- pure (Fupto t1 t2) + t3 <- store v.2 + v.3 <- pure (Fsum t3) + t4 <- store v.3 + (CInt r') @ p.0 <- eval $ t4 + _prim_int_print $ r' + + upto m n = + (CInt m') @ p.2 <- eval $ m + (CInt n') @ p.1 <- eval $ n + b' <- _prim_int_gt $ m' n' + case b' of + #True @ alt.0 -> + v.4 <- pure (CNil) + pure v.4 + #False @ alt.1 -> + x.7 <- pure 1 + m1' <- _prim_int_add $ m' x.7 + v.5 <- pure (CInt m1') + m1 <- store v.5 + v.6 <- pure (Fupto m1 n) + p <- store v.6 + v.7 <- pure (CCons m p) + pure v.7 + + sum l = + l2 <- eval $ l + case l2 of + (CNil) @ alt.2 -> + y.10 <- pure 0 + v.8 <- pure (CInt y.10) + pure v.8 + (CCons x xs) @ alt.3 -> + (CInt x') @ p.4 <- eval $ x + (CInt s') @ p.3 <- sum $ xs + ax' <- _prim_int_add $ x' s' + v.9 <- pure (CInt ax') + pure v.9 - sum p10 p11 = - (Fupto p17 p18) <- fetch p11 - p6 <- pure p17 - p7 <- pure p18 - (CInt n2') <- fetch p6 - (CInt n3') <- fetch p7 - b1' <- _prim_int_gt n2' n3' - do - case b1' of - #True -> - v10_1 <- pure (CNil) - case v10_1 of - (CNil) -> - (CInt n14') <- fetch p10 - pure n14' - (CCons p12 p13) -> - (CInt n5') <- fetch p10 - (CInt n6') <- fetch p12 - n7' <- _prim_int_add n5' n6' - p14 <- store (CInt n7') - sum p14 p13 - #False -> - n4' <- _prim_int_add n2' 1 - p8 <- store (CInt n4') - p9 <- store (Fupto p8 p7) - v10_2 <- pure (CCons p6 p9) - case v10_2 of - (CNil) -> - (CInt n14'_2) <- fetch p10 - pure n14'_2 - (CCons p12_2 p13_2) -> - (CInt n5'_2) <- fetch p10 - (CInt n6'_2) <- fetch p12_2 - n7'_2 <- _prim_int_add n5'_2 n6'_2 - p14_2 <- store (CInt n7'_2) - sum p14_2 p13_2 + eval q = + v <- fetch q + case v of + (CInt x'1) @ alt.4 -> + pure v + (CNil) @ alt.5 -> + pure v + (CCons y ys) @ alt.6 -> + pure v + (Fupto a b) @ alt.7 -> + w <- upto $ a b + p.5 <- update q w + pure w + (Fsum c) @ alt.8 -> + z <- sum $ c + p.6 <- update q z + pure z |] it "Random pipeline" $ do @@ -79,6 +99,7 @@ spec = do transformed2 <- randomPipeline (mkStdGen seed2) opts exp mangleNames transformed1 `sameAs` mangleNames transformed2 + -- TODO: replace with code generation guided by the new syntax -- Needs better code generation. xit "Random pipeline, random expression" $ property $ forAll (PP <$> genProg) $ \(PP prog) -> monadicIO $ run $ do From 75c871e7e59f76b5498c73b8fc75ed8c0bbc3559 Mon Sep 17 00:00:00 2001 From: anabra Date: Mon, 17 Feb 2020 15:54:22 +0100 Subject: [PATCH 10/11] ES: added SumListSpec --- grin/grin.cabal | 1 + .../Samples/ExtendedSyntax/SumListSpec.hs | 97 +++++++++++++++++++ 2 files changed, 98 insertions(+) create mode 100644 grin/test/Samples/ExtendedSyntax/SumListSpec.hs diff --git a/grin/grin.cabal b/grin/grin.cabal index d98330e1..9c6898ac 100644 --- a/grin/grin.cabal +++ b/grin/grin.cabal @@ -382,6 +382,7 @@ test-suite grin-test Transformations.BindNormalisationSpec Transformations.ConfluenceSpec Transformations.MangleNamesSpec + Samples.ExtendedSyntax.SumListSpec Samples.SumListSpec Samples.ArityFullRemoveSpec LintSpec diff --git a/grin/test/Samples/ExtendedSyntax/SumListSpec.hs b/grin/test/Samples/ExtendedSyntax/SumListSpec.hs new file mode 100644 index 00000000..53494080 --- /dev/null +++ b/grin/test/Samples/ExtendedSyntax/SumListSpec.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns #-} +module Samples.ExtendedSyntax.SumListSpec where + +import Pipeline.Pipeline + +import Test.Hspec +import Grin.TH +import Test.Test hiding (newVar) +import Test.Assertions + +runTests :: IO () +runTests = hspec spec + +spec :: Spec +spec = do + -- TODO: Reenable before merge + xit "lazy list sum - half pipeline" $ do + let before = [prog| + grinMain = + p1 <- store (CInt 0) + p2 <- store (CInt 1) + p3 <- store (CInt 1000) + p4 <- store (Fupto p2 p3) + p5 <- store (Fsum p1 p4) + (Fsum p15 p16) <- fetch p5 + n13' <- sum p15 p16 + _prim_int_print n13' + + sum p10 p11 = + (Fupto p17 p18) <- fetch p11 + p6 <- pure p17 + p7 <- pure p18 + (CInt n2') <- fetch p6 + (CInt n3') <- fetch p7 + b1' <- _prim_int_gt n2' n3' + do + case b1' of + #True -> + v10_1 <- pure (CNil) + case v10_1 of + (CNil) -> + (CInt n14') <- fetch p10 + pure n14' + (CCons p12 p13) -> + (CInt n5') <- fetch p10 + (CInt n6') <- fetch p12 + n7' <- _prim_int_add n5' n6' + p14 <- store (CInt n7') + sum p14 p13 + #False -> + n4' <- _prim_int_add n2' 1 + p8 <- store (CInt n4') + p9 <- store (Fupto p8 p7) + v10_2 <- pure (CCons p6 p9) + case v10_2 of + (CNil) -> + (CInt n14'_2) <- fetch p10 + pure n14'_2 + (CCons p12_2 p13_2) -> + (CInt n5'_2) <- fetch p10 + (CInt n6'_2) <- fetch p12_2 + n7'_2 <- _prim_int_add n5'_2 n6'_2 + p14_2 <- store (CInt n7'_2) + sum p14_2 p13_2 + |] + let after = [prog| + grinMain = + n13' <- sum 0 1 1000 + _prim_int_print n13' + + sum p10 p111 p112 = + b1' <- _prim_int_gt p111 p112 + case b1' of + #True -> + pure p10 + #False -> + n4' <- _prim_int_add p111 1 + n7'_2 <- _prim_int_add p10 p111 + sum n7'_2 n4' p112 + |] + let steps = map T + [ BindNormalisation + , ConstantPropagation + , BindNormalisation + , CommonSubExpressionElimination + , CopyPropagation + , SimpleDeadVariableElimination + , ArityRaising + , CopyPropagation + , SimpleDeadVariableElimination + , ArityRaising + , CopyPropagation + , SimpleDeadVariableElimination + ] + + transformed <- pipeline defaultOpts Nothing before steps + transformed `sameAs` after From bd290e5f8ee37fb1c24b14125e9b06b7fcb6578d Mon Sep 17 00:00:00 2001 From: anabra Date: Mon, 17 Feb 2020 16:18:07 +0100 Subject: [PATCH 11/11] ES: updated SumListSpec to new syntax --- .../Samples/ExtendedSyntax/SumListSpec.hs | 150 ++++++++++-------- 1 file changed, 84 insertions(+), 66 deletions(-) diff --git a/grin/test/Samples/ExtendedSyntax/SumListSpec.hs b/grin/test/Samples/ExtendedSyntax/SumListSpec.hs index 53494080..cc649d45 100644 --- a/grin/test/Samples/ExtendedSyntax/SumListSpec.hs +++ b/grin/test/Samples/ExtendedSyntax/SumListSpec.hs @@ -1,12 +1,13 @@ {-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns #-} module Samples.ExtendedSyntax.SumListSpec where -import Pipeline.Pipeline +import Pipeline.ExtendedSyntax.Pipeline import Test.Hspec -import Grin.TH -import Test.Test hiding (newVar) -import Test.Assertions + +import Grin.ExtendedSyntax.TH +import Grin.ExtendedSyntax.PrimOpsPrelude +import Test.ExtendedSyntax.Assertions runTests :: IO () runTests = hspec spec @@ -14,69 +15,86 @@ runTests = hspec spec spec :: Spec spec = do -- TODO: Reenable before merge - xit "lazy list sum - half pipeline" $ do - let before = [prog| - grinMain = - p1 <- store (CInt 0) - p2 <- store (CInt 1) - p3 <- store (CInt 1000) - p4 <- store (Fupto p2 p3) - p5 <- store (Fsum p1 p4) - (Fsum p15 p16) <- fetch p5 - n13' <- sum p15 p16 - _prim_int_print n13' + it "lazy list sum - half pipeline" $ do + let before = withPrimPrelude [prog| + grinMain = + y.0 <- pure 1 + v.0 <- pure (CInt y.0) + t1 <- store v.0 + y.1 <- pure 10000 + v.1 <- pure (CInt y.1) + t2 <- store v.1 + v.2 <- pure (Fupto t1 t2) + t3 <- store v.2 + v.3 <- pure (Fsum t3) + t4 <- store v.3 + (CInt r') @ p.0 <- eval $ t4 + _prim_int_print $ r' + + upto m n = + (CInt m') @ p.2 <- eval $ m + (CInt n') @ p.1 <- eval $ n + b' <- _prim_int_gt $ m' n' + case b' of + #True @ alt.0 -> + v.4 <- pure (CNil) + pure v.4 + #False @ alt.1 -> + x.7 <- pure 1 + m1' <- _prim_int_add $ m' x.7 + v.5 <- pure (CInt m1') + m1 <- store v.5 + v.6 <- pure (Fupto m1 n) + p <- store v.6 + v.7 <- pure (CCons m p) + pure v.7 + + sum l = + l2 <- eval $ l + case l2 of + (CNil) @ alt.2 -> + y.10 <- pure 0 + v.8 <- pure (CInt y.10) + pure v.8 + (CCons x xs) @ alt.3 -> + (CInt x') @ p.4 <- eval $ x + (CInt s') @ p.3 <- sum $ xs + ax' <- _prim_int_add $ x' s' + v.9 <- pure (CInt ax') + pure v.9 - sum p10 p11 = - (Fupto p17 p18) <- fetch p11 - p6 <- pure p17 - p7 <- pure p18 - (CInt n2') <- fetch p6 - (CInt n3') <- fetch p7 - b1' <- _prim_int_gt n2' n3' - do - case b1' of - #True -> - v10_1 <- pure (CNil) - case v10_1 of - (CNil) -> - (CInt n14') <- fetch p10 - pure n14' - (CCons p12 p13) -> - (CInt n5') <- fetch p10 - (CInt n6') <- fetch p12 - n7' <- _prim_int_add n5' n6' - p14 <- store (CInt n7') - sum p14 p13 - #False -> - n4' <- _prim_int_add n2' 1 - p8 <- store (CInt n4') - p9 <- store (Fupto p8 p7) - v10_2 <- pure (CCons p6 p9) - case v10_2 of - (CNil) -> - (CInt n14'_2) <- fetch p10 - pure n14'_2 - (CCons p12_2 p13_2) -> - (CInt n5'_2) <- fetch p10 - (CInt n6'_2) <- fetch p12_2 - n7'_2 <- _prim_int_add n5'_2 n6'_2 - p14_2 <- store (CInt n7'_2) - sum p14_2 p13_2 + eval q = + v <- fetch q + case v of + (CInt x'1) @ alt.4 -> + pure v + (CNil) @ alt.5 -> + pure v + (CCons y ys) @ alt.6 -> + pure v + (Fupto a b) @ alt.7 -> + w <- upto $ a b + p.5 <- update q w + pure w + (Fsum c) @ alt.8 -> + z <- sum $ c + p.6 <- update q z + pure z |] let after = [prog| - grinMain = - n13' <- sum 0 1 1000 - _prim_int_print n13' + -- grinMain = + -- n13' <- sum 0 1 1000 + -- _prim_int_print n13' - sum p10 p111 p112 = - b1' <- _prim_int_gt p111 p112 - case b1' of - #True -> - pure p10 - #False -> - n4' <- _prim_int_add p111 1 - n7'_2 <- _prim_int_add p10 p111 - sum n7'_2 n4' p112 + -- sum p10 p111 p112 = + -- b1' <- _prim_int_gt p111 p112 + -- case b1' of + -- #True -> + -- pure p10 + -- #False -> + -- n4' <- _prim_int_add p111 1 + -- n7'_2 <- _prim_int_add p10 p111 + -- sum n7'_2 n4' p112 |] let steps = map T [ BindNormalisation @@ -84,13 +102,13 @@ spec = do , BindNormalisation , CommonSubExpressionElimination , CopyPropagation - , SimpleDeadVariableElimination + , DeadVariableElimination , ArityRaising , CopyPropagation - , SimpleDeadVariableElimination + , DeadVariableElimination , ArityRaising , CopyPropagation - , SimpleDeadVariableElimination + , DeadVariableElimination ] transformed <- pipeline defaultOpts Nothing before steps